CD ROM Paradise Collection 4

home *** CD-ROM | disk | FTP | other *** search

/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / jx4nt123.zip / JAX4TH.A < prev next >

Wrap

Text File | 1994-09-05 | 132KB | 5,074 lines

TITLE jax4th.a PAGE ,116 ; jax4th.a ... 32-bit ANS Forth for Windows NT ; copyright (c) 1993, 1994 by jack j. woehr ; p.o. box 51, golden, co 80402-0051 ; jax@well.sf.ca.us | JAX on GEnie | 72203.1320@compuserve.com ; sysop, rcfb (303) 278-0364 COMMENT ! This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. (COPYING.TXT) You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ ! .386P .XLIST include listing.inc ; this may not be needed .LIST include jax4th.i .XLIST include windows.i .LIST _TEXT SEGMENT DWORD USE32 PUBLIC 'CODE' _TEXT ENDS _DATA SEGMENT DWORD USE32 PUBLIC 'DATA' _DATA ENDS .MODEL FLAT _DATA SEGMENT DWORD USE32 PUBLIC 'DATA' .SALL ; suppress listing of Unicode macro expansion myMsg: unicode <Jax4th for Windows NT> DW 0ah, 0dh unicode <Copyright (c) 1993, 1994 Jack J. Woehr> DW 0ah, 0dh unicode <Covered under the GNU Public License.> DW 0ah, 0dh myMsgLen = ($-myMsg)/tchar orderMsg0: unicode <Search Order: > orderMsg0Len = ($-orderMsg0)/tchar orderMsg1: unicode <Current Compilation Wordlist: > orderMsg1Len = ($-orderMsg1)/tchar throwMsg: unicode <THROW #> throwMsgLen = ($-throwMsg)/tchar byeMsg: unicode <Goodbye from Jax4th.> DW 0ah, 0dh byeMsgLen = ($-byeMsg)/tchar gnuMsg: unicode < Jax4th $Revision: 1.23 $ (C) 1993, 1994 Jack J. Woehr> DW 0ah, 0dh unicode < Jax4th comes with ABSOLUTELY NO WARRANTY.> DW 0ah, 0dh unicode < This is free software, and you are welcome to redistribute it > DW 0ah, 0dh unicode < under certain conditions. See file COPYING.TXT for more info.> DW 0ah, 0dh unicode < Type ABOUT to see this message again.> DW 0ah, 0dh gnuMsgLen = ($-gnuMsg)/tchar ;--( Forth Messages ) okPrompt dw 3 unicode < ok> listMsg1 dw 7 unicode <Block: > listMsg2 dw 9 unicode <File ID: > stackUnderMsg dw 12 unicode <Stack under.> undefinedMsg dw 10 unicode <Undefined.> compOnlyMsg dw 17 unicode <Compilation only.> toBodyMsg dw 22 unicode <Not a child of CREATE.> blockWriteMsg dw 18 unicode <BLOCK write error.> blockReadMsg dw 17 unicode <BLOCK read error.> blockNumMsg dw 21 unicode <Invalid BLOCK number.> fileIOMsg dw 20 unicode <File I/O exception: > cStackMsg dw 20 unicode <Control stack error.> conStructMsg dw 26 unicode <Control structure mismatch.> zeroStringMsg dw 17 unicode <Zero-length name.> srchOverMsg dw 22 unicode <Search order overflow.> srchUnderMsg dw 23 unicode <Search order underflow.> compNestMsg dw 17 unicode <Compiler nesting.> ;--( Various Messages ) dumpHdr dw 56 unicode <Address 0100 0302 0504 0706 0908 0B0A 0D0C 0F0E Unicode> unnamedHdr dw 3, 0fffeH, 0fffeH, 0fffeH ; invalid name character for headerless widMsg dw 5 unicode <named> wlHdr dw 11 unicode <Wordlists: > .XALL ; back to normal listing of macro expansion ;--( Kernel Variables) numWritten DD ? ; for calls to WriteConsoleW secAttrib SECURITY_ATTRIBUTES <> ; for calls to CreateFileW fileInfo _BY_HANDLE_FILE_INFORMATION <> ; for calls to GetFileInformationByHandle saveFile OPENFILENAME <> ; for calls to GetSaveFileName numRead DD ? ; number of chars read distMoveHigh DD ? ; used by REPOSITION-FILE lastReadConW DW ? ; used by KEY and others inRecArray INPUT_RECORD 256 DUP (<>) ; for KEY? _DATA ENDS _TEXT SEGMENT DWORD USE32 PUBLIC 'CODE' ;-------------------------------; ; Define API Entry ; ;-------------------------------; ;PUBLIC _main ; satisfies console subsystem ;-----------------------; ; Main Program ; ;-----------------------; _main PROC NEAR ; enter program ;--( We have to create an NT app exception frame by hand in our assembly-language program.) push ebp mov ebp, esp sub esp, 20 push ebx push esi push edi ;--( Now off we go) cld ; !!!***!!! NEXT depends on it, it's this way at boot anyway, but for good luck! jmp boot ; apropos the above, see MOVE ;---------------; ; Forth ; ;---------------; ;--( Execution ) ; Implementation detail zname <NEST> ; this doesn't have an exe engine, it *is* one, musn't be called from Forth interpretively nest: pushrp ip ; @(--RP) := IP lea ip,cell[wp] ; IP := @(WP+4) next zname <DOCONST> ; -- x push DWORD PTR cell[wp] ; Implementation detail next ; Execution engine, works for VARIABLE, also zname <DODEFER> ; i*x -- j*x, deferred word engine mov wp,cell[wp] ; get exe vector storage offset add wp,dp ; add base address mov wp,[wp] ; deref to get token store there innext ; go fer it zname <DODOES> ; -- x ; Implementation detail push DWORD PTR cell[wp] ; push data pointer for this CREATE child mov wp,((2*cell))[wp] ; WP := xt for DOES> code dereftok ; now is a pointer jmp nest zname <UNNEST> ; -- x R: nest-sys -- docode ; Implementation detail poprpto ip ; IP := @RP++ next ; Same routine as above but different name for a debugger to recognize fname <EXIT> ; -- R: nest-sys -- docode ; CORE poprpto ip ; IP := @RP++ next zname <DOKWORDLIST> ; -- abs-addr ; Implementation detail, Execution engine for wordlists declared in the kernel lea edx,cell[wp] ; self-pointer to cell in wordlist code body where data address stored push edx ; push next zname <DOWORDLIST> ; -- a-addr ; Implementation detail, Execution engine for wordlists created by user lea edx,cell[wp] ; get self-pointer of a Wordlist code body where data address stored add edx,cp ; convert from user dict address to abs address push eax ; push next fname <EXECUTE> ; i*x xt -- j*x docode ; CORE pop wp innext zname <DOLIT> ; -- x docode ; Implementation detail lodsd ; advance instruction pointer fetching literal value push eax ; push literal next zname <DODLIT> ; -- docode ; Implementation detail lodsd ; advance instruction pointer fetching literal value mov edx,eax ; save hi 32 bits lodsd ; advance instruction pointer fetching literal value push eax ; push literal loword push edx ; push literal hiword next zname <DOIF> ; flag -- docode ; Implementation detail, also is UNTIL pop eax and eax,eax ; test flag je doelse ; if zero, we branch add ip,cell ; wasn't zero, we advance IP next zname <DOELSE> ; -- docode ; Implementation detail, also is AGAIN, REPEAT doelse: mov wp,[ip] dereftok mov ip,wp next zname <DOUNTIL> ; flag -- docode ; Implementation detail pop eax and eax,eax ; test flag je doelse ; if zero, we branch add ip,cell ; was zero, we advance IP next zname <DOUNTILNOT> ; flag -- docode ; Implementation detail, used this once, not sure why .. pop eax and eax,eax ; test flag jne doelse ; if nonzero, we branch add ip,cell ; was zero, we advance IP next zname <DODO> ; u1 u2 -- docode ; Implementation detail dodo: lodsd ; WP := exit address dereftok pushrp wp ; save exit address on return stack pop eax ; inner loop index pop edx ; outer loop index add edx,80000000H ; add overflow limit to outer sub eax,edx ; massage inner pushrp edx ; push massaged outer to RStack pushrp eax ; push massaged inner to RStack next zname <DOQDO> ; u1 u2 -- docode ; Implementation detail mov edx,[esp] ; copy of TOS cmp cell[esp],edx ; compare to other index jne dodo ; they are different: go ahead and DO add esp,(2*cell) ; same: clear stack lodsd ; WP := @IP++ dereftok mov ip,wp ; IP := WP i.e., exit address compiled in cell ahead of DOQDO token next ; onwards zname <DOLOOP> ; -- docode ; Implementation detail doloop: poprpto eax ; massaged inner index inc eax ; increment jo doloop1 ; overflow flag, we're done pushrp eax ; not done, return incremented count lodsd ; WP := @IP++, i.e., WP is loaded with branchback address dereftok mov ip,wp ; IP := branch back next ; continue doloop1: add rp,(2*cell) ; clear return stack add ip,cell ; branch past loopback address next ; onwards and outwards zname <DOPLUSLOOP> ; n1 -- docode ; Implementation detail poprpto eax ; massaged inner index pop edx ; increment add eax,edx ; add increment to index jo doloop1 ; overflow flag, we're done, we can re-use the above code pushrp eax ; not done, return incremented count lodsd ; WP := @IP++, i.e., WP is loaded with branchback address dereftok mov ip,wp ; IP := branch back next ; continue ; Strings for S" and TYPE must reside in data space. In the dictionary they are recorded /DOSQUOTE/D-ADDR/ zname <DOSQUOTE> ; -- c-addr u docode ; Implementation detail lodsd ; count address in ax xor edx,edx ; clear dx mov dx,[eax][dp] ; get count add eax,tchar ; form data address of string push eax ; push c-addr push edx ; push u next zname <DODOTQUOTE> ; -- docode ; Implementation detail lodsd ; count address in wp (EAX) xor edx,edx ; clear dx mov dx,[eax+dp] ; get count add eax,tchar ; form data address of string push eax ; push c-addr push edx ; push u jmp ftype ; goto type zname <DOKDOTQUOTE> ; -- Print strings stored in the kernel exe data section docode ; Implementation detail. lodsd ; count address in wp (EAX) sub eax,dp ; convert to data-relative address xor edx,edx ; clear dx mov dx,[eax+dp] ; get count add eax,tchar ; form data address of string push eax ; push c-addr push edx ; push u jmp ftype ; goto typ ;--( Stack Operators ) fname <DROP> ; x -- docode ; CORE pop eax next fnamemanque <2DROP> ; x1 x2 -- fw_TWO_DROP: docode ; CORE pop eax pop eax next fnamemanque <?DUP> ; x -- x x | 0 fw_QDUP: docode ; CORE cmp DWORD PTR [esp],0 jne dupe next fname <DUP> ; x -- x x docode ; CORE dupe: push [esp] next fnamemanque <2DUP> ; x1 x2 -- x1 x2 x1 x2 fw_TWO_DUP: docode ; CORE push cell[esp] push cell[esp] next fname <OVER> ; x1 x2 -- x1 x2 x1 dd over ; CORE over: push cell[esp] next fnamemanque <2OVER> ; x1 x2 x3 x4-- x1 x2 x3 x4 x1 x2 fw_TWO_OVER: docode ; CORE push (3*cell)[esp] push (3*cell)[esp] next fname <ROT> ; x1 x2 x3 -- x2 x3 x1 docode ; CORE pop eax pop ecx pop edx push ecx push eax push edx next nnamemanque <-ROT> ; x1 x2 x3 -- x3 x1 x2 fw_NEGROT: ; Not in Standard docode pop eax pop ecx pop edx push eax push edx push ecx next fname <SWAP> ; x1 x2 -- x2 x1 docode ; CORE pop eax pop edx push eax push edx next fnamemanque <2SWAP> ; x1 x2 x3 x4-- x3 x4 x1 x2 fw_TWO_SWAP: ; CORE docode mov eax,(3*cell)[esp] mov edx,cell[esp] mov (3*cell)[esp],edx mov cell[esp],eax mov eax,((2*cell))[esp] mov edx,[esp] mov ((2*cell))[esp],edx mov [esp],eax next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '>',0,'R',0 ; x -- R: -- x align 4 ; CORE fw_TO_R: docode sub rp,cell pop [rp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db '2',0,'>',0,'R',0 ; x1 x2 -- R: -- x1 x2 align 4 ; CORE EXT fw_TWO_TO_R: docode pop eax sub rp,cell pop [rp] sub rp,cell mov [rp],eax next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'R',0,'>',0 ; -- x R: x -- align 4 ; CORE fw_R_FROM: docode push [rp] add rp,cell next ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db '2',0,'R',0,'>',0 ; -- x1 x2 R: x1 x2 -- align 4 ; CORE EXT fw_TWO_R_FROM: docode mov eax,[rp] add rp,cell push [rp] add rp,cell push eax next fnamemanque <R@> ; -- x R: x -- x fw_R_FETCH: ; CORE docode push DWORD PTR [rp] next ; Can't use our name header macros with this one! linkme nlinkptr countcell 3 db 'R',0,'P',0,'!',0 ; addr -- align 4 ; Implementation fw_RP_STORE: docode pop rp next nnamemanque <RP@> fw_RP_FETCH: ; -- addr docode ; Implementation push rp next fname <TUCK> ; x1 x2 -- x2 x1 x2 docode ; CORE EXT pop eax pop edx push eax push edx push eax next fname <NIP> ; x1 x2 -- x2 docode ; CORE EXT pop eax pop edx push eax next fname <PICK> ; xu .. x1 x0 u -- xu .. x1 x0 xu docode ; CORE EXT pop eax push [esp][eax*cell] next fname <DEPTH> ; i*x -- i*x i ctok NEST ; CORE ctok SP_FETCH ; -- @esp ctok SP0 ctok FETCH ; -- @esp @orig-esp ctok SWAP ctok MINUS ; -- diff literal 1 ctok CELLS ; -- diff cell-size ctok SLASH ; -- cells-diff ctok UNNEST ; Get current data stack pointer value, an absolute address nnamemanque <SP@> ; -- abs-addr fw_SP_FETCH: ; Not in Standard docode push esp next ; Can't use our name header macros with this one! linkme nlinkptr countcell 3 db 'S',0,'P',0,'!' ; abs-addr -- Set data stack pointer value, an absolute address align 4 fw_SP_STORE: ; Not in Standard docode pop esp next ; Get saved-at-boot data stack pointer value nname <SP0> ; -- a-addr ctok DOCONST ; Not in Standard dd ntConESP ;--( Data Movement ) ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '!',0 ; x a-addr -- align 4 ; CORE fw_STORE: docode pop eax pop [eax][dp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '+',0,'!',0 ; x a-addr -- align 4 ; CORE fw_PL_STORE: docode pop eax pop edx add [eax][dp],edx next fnamemanque <@> ; a-addr -- x fw_FETCH: docode ; CORE pop eax push [eax][dp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'C',0,'!',0 ; c c-addr -- align 4 ; CORE fw_C_STORE: docode pop eax pop edx mov [eax][dp],dx next fnamemanque <C@> ; c-addr -- c fw_C_FETCH: docode ; CORE mov eax,[esp] mov dx,[eax][dp] movzx eax,dx mov [esp],eax next ; Can't use our name header macros with this one! linkme nlinkptr countcell 2 db 'B',0,'!',0 ; byte c-addr -- align 4 ; Not in Standard fw_B_STORE: docode pop eax pop edx mov [eax][dp],dl next nnamemanque <B@> ; c-addr -- byte fw_B_FETCH: docode ; Not in Standard mov eax,[esp] mov dl,[eax][dp] movzx eax,dl mov [esp],eax next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '2',0,'!',0 ; x1 x2 a-addr -- align 4 ; CORE fw_TWO_STORE: docode pop eax pop [eax][dp] pop [eax+cell][dp] next fnamemanque <2@> ; a-addr -- x1 x2 fw_TWO_FETCH: docode ; CORE pop eax push [eax+cell][dp] push [eax][dp] next ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db ',',0 ; x -- align 4 ; CORE fw_COMMA: docode mov eax,[dp+datap] ; get data space pointer pop [eax][dp] ; pop to that offset in data space add DWORD PTR datap[dp],cell ; post-increment pointer next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'C',0,',',0 ; char -- align 4 ; CORE fw_CCOMMA: docode mov eax,[dp+datap] ; get data space pointer pop edx ; get char mov [eax][dp],dx ; pop char to that offset in data space add DWORD PTR datap[dp],tchar ; post-increment pointer next fname <MOVE> ; addr1 addr2 u -- docode pop ecx ; count pop eax ; destination pop edx ; source and ecx,ecx ; is count zero? je move2 ; if zero count, exit cld ; now set to move string upwards cmp eax,edx ; destination - source jb move1 ; jump if destination < source, continue further on add eax,ecx dec eax add edx,ecx dec edx std ; destination >= source, copy downwards move1: add eax,dp ; absolute destination add edx,dp ; absolute source push edi ; save edi push esi ; save esi push edx ; load source pop esi push eax ; load dest pop edi push ds ; same seg .. pop es ; .. for source and dest rep movsb ; copy address units ... this can be optimized later pop esi ; restore esi pop edi ; restore edi cld ; !!!***!!! VERY IMPORTANT because NEST depends on it !!!***!!! move2: next ;--( Comparisons ) ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '0',0,'<',0 ; x -- flag align 4 ; CORE fw_ZEROLT: docode mov eax,[esp] shl eax,1 sbb edx,edx mov [esp],edx next fnamemanque <0=> ; x -- flag fw_ZEROEQ: docode ; CORE mov eax,[esp] and eax,eax je zeroeq1 mov DWORD PTR [esp],FALSE next zeroeq1: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db '0',0,'<',0,'>',0 ; x -- flag align 4 ; CORE EXT fw_ZERONE: docode mov eax,[esp] and eax,eax jne zeroeq1 ; reuse code above mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '0',0,'>',0 ; x -- flag align 4 ; CORE EXT fw_ZEROGT: ctok NEST ctok DUP ; -- x x ctok ZEROLT ; -- x flag ctok SWAP ; -- flag x ctok ZEROEQ ; -- flag1 flag2 ctok OR ; -- flag ctok ZEROEQ ; -- flag' ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '<',0 ; n1 n2 -- flag align 4 ; CORE fw_LESS: docode pop eax mov edx,[esp] cmp edx,eax jl less1 mov DWORD PTR [esp],FALSE next less1: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'U',0,'<',0 ; u1 u2 -- flag align 4 ; CORE fw_U_LESS: docode pop eax mov edx,[esp] cmp edx,eax jb less1 ; we can re-use code from above mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme nlinkptr countcell 3 db 'U',0,'D',0,'<',0 ; ud1 ud2 -- flag align 4 ; Not in standard fw_UD_LESS: docode pop edx ; ud2h pop eax ; ud2l pop ecx ; ud1h cmp edx,ecx ; ud2h ja udless ; if ud2h > ud1h, TRUE jb nudless ; if ud2h < ud1h, FALSE cmp eax,[esp] ; they were equal, try low half ja udless ; now if ud2l > ud1l, TRUE nudless: ; ud2l =< ud1l, FALSE mov DWORD PTR [esp],FALSE next udless: mov DWORD PTR [esp],TRUE next nname <UDMIN> ; ud1 ud2 -- ud1|ud2 ctok NEST ; Not in standard ctok TWO_OVER ctok TWO_OVER ; -- ud1 ud2 ud1 ud2 ctok D_EQUAL ; -- ud1 ud2 flag compif udmin1 ; they're the same, drop the top ctok TWO_DROP ctok EXIT udmin1: ctok TWO_OVER ctok TWO_OVER ; -- ud1 ud2 ud1 ud2 ctok UD_LESS ; -- ud1 ud2 flag compif udmin2 ; is ud1 ud< u2? ctok TWO_DROP ; -- ud1, yes, leave ud1 ctok EXIT udmin2: ; no, so ud1 u> ud2 ctok ROT ctok DROP ctok ROT ctok DROP ; -- ud2 ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db 'D',0,'=',0 ; xd1 xd2 -- flag align 4 ; DOUBLE fw_D_EQUAL: docode pop edx ; d2h pop eax ; d2l pop ecx ; d1h cmp edx,ecx ; d2h == d1h? jne dnequal ; no cmp eax,[esp] ; yes, try lower jne dnequal ; d2l != d1l mov DWORD PTR [esp],TRUE ; d2l == d1l next dnequal: mov DWORD PTR [esp],FALSE next fnamemanque <D0=> ; xd -- flag fw_D_ZEROEQ: ; DOUBLE docode pop eax and eax,eax jne dzeroeq1 or eax,[esp] jne dzeroeq1 mov DWORD PTR [esp],TRUE next dzeroeq1: mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '=',0 ; x1 x2 -- flag align 4 ; CORE fw_EQUAL: docode pop eax mov edx,[esp] cmp eax,edx je equal1 mov DWORD PTR [esp],FALSE next equal1: mov DWORD PTR [esp],TRUE next ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '<',0,'>',0 ; x1 x2 -- flag align 4 ; CORE EXT fw_NEQUAL: docode pop eax mov edx,[esp] cmp eax,edx jne equal1 ; re-using above code mov DWORD PTR [esp],FALSE next ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db '>',0 ; n1 n2 -- flag align 4 ; CORE fw_GREATER: docode pop eax mov edx,[esp] cmp edx,eax ja greater1 mov DWORD PTR [esp],FALSE next greater1: mov DWORD PTR [esp],TRUE next fname <MAX> ; n1 n2 -- n3 docode ; CORE pop eax pop edx cmp eax,edx jl f_max1 push eax next f_max1: push edx next fname <MIN> ; n1 n2 -- n3 docode ; CORE pop edx pop eax cmp eax,edx ja f_max1 ; reuse code from above push eax next fname <WITHIN> ; n|u1 n|u2 n|u3 -- flag ctok NEST ; CORE EXT ctok OVER ctok MINUS ; -- n1 n2 diffn3n2 ctok TO_R ; -- n1 n2 R: -- diffn3n2 ctok MINUS ; -- diffn1n2 R: -- diffn3n2 ctok R_FROM ; -- diffn1n2 diffn3n2 R: -- ctok U_LESS ; -- flag ctok UNNEST ;--( Integer Math ) fnamemanque <1+> ; n|u1 -- n|u2 fw_ONE_PLUS: docode add DWORD PTR [esp],1 next fnamemanque <1-> ; n|u1 -- n|u2 fw_ONE_MINUS: docode sub DWORD PTR [esp],1 next fname <ABS> ; n -- u ctok NEST ; CORE ctok DUP ctok ZEROLT ; -- n flag compif abs1 ctok NEGATE abs1: ctok UNNEST ; -- _n_ fname <DABS> ; d -- ud ctok NEST ; DOUBLE ctok DUP ctok ZEROLT ; -- d flag compif dabs1 ctok DNEGATE dabs1: ctok UNNEST ; -- _d_ ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db 'S',0,'>',0,'D',0 ; n1 -- d1 align 4 ; CORE fw_S_TO_D: docode mov eax,[esp] cdq push edx next ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db 'D',0,'>',0,'S',0 ; d1 -- s1 align 4 ; DOUBLE fw_D_TO_S: docode pop eax next fname <NEGATE> ; n1 -- n2 docode ; CORE mov eax,[esp] neg eax mov [esp],eax next fname <DNEGATE> ; d1 -- d2 docode ; DOUBLE xor eax,eax xor edx,edx sub eax,cell[esp] sbb edx,[esp] mov cell[esp],eax mov [esp],edx next fnamemanque <+> ; n|u1 n|u2 -- n|u3 fw_PLUS: ; CORE docode pop eax add [esp],eax next fnamemanque <D+> ; ud|d1 ud|d2 -- ud|d3 fw_D_PLUS: ; DOUBLE docode pop edx ; d2h pop eax ; d2l add cell[esp],eax ; d1l+d2l adc [esp],edx ; d1h+d2h+carry next fnamemanque <-> ; n|u1 n|u2 -- n|u3 fw_MINUS: ; CORE docode pop eax sub [esp],eax next fnamemanque <D-> ; ud|d1 ud|d2 -- ud|d3 fw_D_MINUS: ; DOUBLE docode pop edx ; d2h pop eax ; d2l sub cell[esp],eax ; d1l-d2l sbb [esp],edx ; d1h-d2h-borrow next fnamemanque <*> ; n|u1 n|u2 -- n|u3 fw_STAR: ; CORE docode pop eax imul DWORD PTR[esp] mov [esp],eax next fnamemanque </> ; n1 n2 -- n3 fw_SLASH: ; CORE docode pop ecx ; n2 pop eax ; n1 xor edx,edx ; high order for div idiv ecx ; n1 / n2 push eax ; quotient next ; -- n3 fnamemanque </MOD> ; n1 n2 -- n3 n4 fw_SLMOD: ; CORE docode pop ecx ; n2 pop eax ; n1 xor edx,edx ; high order for div idiv ecx ; n1 / n2 push edx ; remainder push eax ; quotient next ; -- n3 n4 fname <MOD> ; n1 n2 -- n3 ctok NEST ctok SLMOD ctok DROP ctok UNNEST fnamemanque <*/> ; n1 n2 n3 -- n4 fw_STARSL: ; CORE docode pop ecx ; n3 pop edx ; n2 pop eax ; n1 imul edx ; n1 * n2 idiv ecx ; intermediate / n3 push eax ; quotient next ; -- n4 fnamemanque <*/MOD> ; n1 n2 n3 -- n4 n5 fw_STARSLMOD: ; CORE docode pop ecx ; n3 pop edx ; n2 pop eax ; n1 imul edx ; n1 * n2 idiv ecx ; intermediate / n3 push edx ; remainder push eax ; quotient next ; -- n4 n5 nnamemanque <DUM/MOD> ; d1 n1 -- n2 d2 fw_DUMSLMOD: ; not in Standard ctok NEST ctok TO_R ; -- d1l d1h R: -- n1 literal 0 ; -- d1l d1h 0 R: -- n1 ctok R_FETCH ; -- d1l d1h 0 n1 R: -- n1 ctok UMSLMOD ; -- d1l r1 q1 R: -- n1 ctok R_FROM ; -- d1l r1 q1 n1 R: -- ctok SWAP ; -- d1l r1 n1 q1 R: -- ctok TO_R ; -- d1l r1 n1 R: -- d2h ctok UMSLMOD ; -- r2 q2 R: -- d2h ctok R_FROM ; -- n2 d2 ctok UNNEST ; -- n2 d2 fnamemanque <FM/MOD> ; d1 n1 -- n2 n3 fw_FMSLMOD: ; CORE ctok NEST ctok DUP ; -- d1 n1 ctok TO_R ; -- d1 n1 R: -- n1 ctok ZEROLT ; -- d1 flag R: -- n1 compif fmslmod1 ctok DNEGATE fmslmod1: ctok S_TO_D ; -- d1l d1hl d1hh R: -- n1 ctok R_FETCH ; -- d1l d1hl d1hh n1 R: -- n1 ctok ABS ; -- d1l d1hl d1hh _n1_ R: -- n1 ctok AND ; -- d1l d1hl d1hh _n1_ R: -- n1 ctok PLUS ; -- d1l intermed R: -- n1 ctok R_FETCH ; -- d1l intermed n1 R: -- n1 ctok ABS ; -- d1l intermed _n1_ R: -- n1 ctok UMSLMOD ; -- n2' n3 R: -- n1 ctok SWAP ; -- n3 n2' R: -- n1 ctok R_FROM ; -- n3 n2' n1 R: -- ctok ZEROLT ; -- n3 n2' flag compif fmslmod2 ctok NEGATE ; -- n3 n2 fmslmod2: ctok SWAP ; -- n2 n3 ctok UNNEST fnamemanque <SM/REM> ; d1 n1 -- n2 n3 fw_SMSLREM: ; CORE docode pop ecx ; u1 pop edx ; udh pop eax ; udl idiv ecx push edx ; remainder push eax ; quotient next ; -- u2 u3 fnamemanque <UM*> ; u1 u2 -- ud fw_UMSTAR: ; CORE docode mov eax,cell[esp] ; u1 mul DWORD PTR [esp] ; u1*u2 mov cell[esp],eax ; udl mov [esp],edx ; udh next ; -- ud fnamemanque <UM/MOD> ; ud u1 -- u2 u3) fw_UMSLMOD: ; CORE docode pop ecx ; u1 pop edx ; udh pop eax ; udl div ecx push edx ; remainder push eax ; quotient next ; -- u2 u3 fnamemanque <M*> ; n1 n2 -- d fw_MSTAR: ; CORE docode mov eax,cell[esp] ; n1 imul DWORD PTR [esp] ; n1*n2 mov cell[esp],eax ; dl mov [esp],edx ; dh next ; -- ud nnamemanque <UD*U> ; ud1 u1 -- ud2 fw_UDSTARU: ; not in standard docode pop ecx ; u1 pop eax ; ud1h mul ecx ; produce extended ud2h mov edx,ecx ; discard upper dword of ud2he, move multiplier into edx mov ecx,eax ; save lower portion of ud2he in ecx pop eax ; ud1l mul edx ; ud2l in eax push eax ; return ud2l add edx,ecx ; form ud2h push edx ; return ud2h next ; -- ud2 ;--( Bit Operators ) fname <TRUE> ; -- flag ctok DOCONST ; CORE EXT dd TRUE fname <FALSE> ; -- flag ctok DOCONST ; CORE EXT dd FALSE fname <AND> ; x1 x2 -- x3 docode ; CORE pop eax and [esp],eax next fname <OR> ; x1 x2 -- x3 docode ; CORE pop eax or [esp],eax next fname <XOR> ; x1 x2 -- x3 docode ; CORE pop eax xor [esp],eax next fname <INVERT> ; x1 -- x2 docode ; CORE mov eax,[esp] not eax mov [esp],eax next fnamemanque <2*> ; x1 -- x2 fw_TWO_STAR: ; CORE docode mov eax,[esp] shl eax,1 mov [esp],eax next fnamemanque <2/> ; x1 -- x2 fw_TWO_SLASH: ; CORE docode mov eax,[esp] shr eax,1 mov [esp],eax next fname <LSHIFT> ; x1 u -- x2 docode ; CORE pop ecx mov eax,[esp] shl eax,cl mov [esp],eax next fname <RSHIFT> ; x1 u -- x2 docode ; CORE pop ecx mov eax,[esp] shr eax,cl mov [esp],eax next ;--( Characters ) fname <BL> ; -- char ctok DOCONST ; CORE dd 20H fname <CHAR> ; -- char ctok NEST ; CORE ctok BL ctok WORD ctok CHAR_PLUS ctok C_FETCH ctok UNNEST finamemanque <[CHAR]> ; -- Execution: -- char fw_BRACHETCHAR: ctok NEST ; CORE ctok CHAR ctok LITERAL ctok UNNEST fname <SPACE> ; -- ctok NEST ; CORE ctok BL ctok EMIT ctok UNNEST fname <SPACES> ; n -- ctok NEST ; CORE literal 0 ctok MAX literal 0 compqdo spaces1 spaces0: ctok SPACE comploop spaces0 spaces1: ctok UNNEST fnamemanque <CHAR+> ; c-addr1 -- c-addr2 fw_CHAR_PLUS: ; CORE docode add DWORD PTR [esp],tchar next fname <CHARS> ; n1 -- n2 ctok NEST ; CORE literal tchar ctok STAR ctok UNNEST fname <FILL> ; c-addr u char -- docode ; CORE pop eax ; char pop ecx ; count pop edx ; dest jecxz fill_done ; zero count? we're done before we start add edx,dp ; abs addr push ds pop es ; same seg, this is default, but user might have changed it in a CODE word push edi ; save edi push edx pop edi ; load destination rep stosw ; store char pop edi ; restore edi fill_done: next ;--( Strings ) fnamemanque </STRING> ; c-addr1 u1 n -- c-addr2 u2 fw_SLSTRING: ctok NEST ctok ROT ; -- u1 n c-a1 ctok OVER ; -- u1 n c-a1 n ctok CHARS ; -- u1 n c-a1 nbytes ctok PLUS ; -- u1 n c-a2 ctok NEGROT ; -- c-a2 u1 n ctok MINUS ; -- c-a2 u2 ctok UNNEST fname <CMOVE> ; c-addr1 c-addr2 u -- ctok NEST ; STRING ctok QDUP ; -- c-addr1 c-addr2 [ u u | 0 ] ctok ZEROEQ compif cmove1 ctok TWO_DROP ; -- ctok EXIT cmove1: literal 0 compdo cmove3 cmove2: ctok OVER ; -- c-addr1 c-addr2 c-addr1 ctok C_FETCH ; -- c-addr1 c-addr2 char ctok OVER ; -- c-addr1 c-addr2 char c-addr2 ctok C_STORE ; -- c-addr1 c-addr2 ctok CHAR_PLUS ; -- c-addr1 c-addr2' ctok SWAP ctok CHAR_PLUS ; -- c-addr2' c-addr1' ctok SWAP ; -- c-addr1' c-addr2' comploop cmove2 cmove3: ctok TWO_DROP ctok UNNEST ; -- ; Can't use our name header macros with this one! linkme flinkptr countcell 6 db 'C',0,'M',0,'O',0,'V',0,'E',0,'>',0 ; c-addr1 c-addr2 u -- align 4 ; STRING fw_CMOVER: ctok NEST ctok QDUP ; -- c-addr1 c-addr2 [ u u | 0 ] ctok ZEROEQ compif cmover1 ctok TWO_DROP ; -- ctok EXIT cmover1: ctok DUP ; -- c-addr1 c-addr2 u u ctok TO_R ; -- c-addr1 c-addr2 u R: -- u ctok CHARS ; -- c-addr1 c-addr2 u' R: -- u ctok TUCK ; -- c-addr1 u' c-addr2 u' R: -- u ctok PLUS ; -- c-addr1 u' c-addr2' R: -- u ctok TO_R ; -- c-addr1 u' R: -- u c-addr2' ctok PLUS ; -- c-addr1' R: -- u c-addr2' ctok R_FROM ctok R_FROM ; -- c-addr1' c-addr2' u literal 0 compdo cmover3 cmover2: literal tchar ; -- c-addr1' c-addr2' n ctok MINUS ; -- c-addr1' c-addr2'' ctok SWAP literal tchar ctok MINUS ; -- c-addr2'' c-addr1'' ctok SWAP ; -- c-addr1'' c-addr2'' ctok OVER ; -- c-addr1'' c-addr2'' c-addr1'' ctok C_FETCH ; -- c-addr1'' c-addr2'' char ctok OVER ; -- c-addr1'' c-addr2'' char c-addr2'' ctok C_STORE ; -- c-addr1'' c-addr2'' comploop cmover2 cmover3: ctok TWO_DROP ; -- ctok UNNEST fname <COUNT> ; c-addr1 -- c-addr2 u docode mov eax,[esp] xor edx,edx mov dx,[eax][dp] add eax,tchar mov [esp],eax push edx next fname <COMPARE> ; c-addr1 u1 c-addr2 u2 -- n docode ; STRING pop ecx ; u2 pop edx ; c-addr2 add edx,dp ; convert to abs addr pop eax ; u1 cmp ecx,eax ; counts equal? je compare_e ; yes, continue further on jl compare_u1 ; if u2 (in ecx) is lesser, continue further on mov ecx,eax ; u2 > u1 mov eax,[esp] ; c-addr1 add eax,dp ; convert to abs addr push esi ; preserve push edi ; preserve push ds ; pop es ; set ES, this is probably redundant in view of system requirements mov esi,eax ; c-addr1 mov edi,edx ; c-addr2 cld ; direction upwards repe cmpsw ; unicode is 2-byte chars je compare_neg1 ; all matched, u2 > u1 mov ax,[esi] cmp ax,[edi] ; compare non-match c-addr1 char to c-addr2 char jl compare_neg1 ; c-addr1 char is less jmp SHORT compare_1 ; c-addr2 char is less compare_u1: ; u1 > u2 mov eax,[esp] ; c-addr1 add eax,dp ; convert to abs addr push esi ; preserve push edi ; preserve push ds ; pop es ; set ES, this is probably redundant in view of system requirements mov esi,eax ; c-addr1 mov edi,edx ; c-addr2 cld ; direction upwards repe cmpsw ; unicode is 2-byte chars je compare_1 ; all matched, u1 > u2 mov ax,[esi] cmp ax,[edi] ; compare non-match c-addr1 char to c-addr2 char jl compare_neg1 ; c-addr1 char is less jmp SHORT compare_1 ; c-addr2 char is less compare_e: ; u1 = u2 mov eax,[esp] ; c-addr1 add eax,dp ; convert to abs addr push esi ; preserve push edi ; preserve push ds ; pop es ; set ES, this is probably redundant in view of system requirements mov esi,eax ; c-addr1 mov edi,edx ; c-addr2 cld ; direction upwards repe cmpsw ; unicode is 2-byte chars je compare_0 ; all matched mov ax,[esi-2] ; since we're pointing one past the unmatching char cmp ax,[edi-2] ; compare non-match c-addr1 char to c-addr2 char jl compare_neg1 ; c-addr1 char is less jmp SHORT compare_1 ; c-addr2 char is less compare_0: xor eax,eax mov ((2*cell))[esp],eax ; strings are equal and u1 = u2 jmp SHORT compare_done compare_1: mov eax,1 mov ((2*cell))[esp],eax ; char at first non-match in c-addr1 .gt. corresponding in c-addr2 jmp SHORT compare_done ; or strings equal, and u1 > u2 compare_neg1: mov eax,-1 mov ((2*cell))[esp],eax ; char at first non-match in c-addr1 .lt. corresponding in c-addr2 jmp SHORT compare_done ; or strings equal, and u1 < u2 compare_done: pop edi pop esi next nname <PLACE> ; c-addr1 u c-addr2 ctok NEST ; Not in Standard ctok TWO_DUP ; c-addr1 u c-addr2 u c-addr2 ctok C_STORE ; c-addr1 u c-addr2 ctok CHAR_PLUS ; c-addr1 u c-addr2' ctok SWAP ; c-addr1 c-addr2' u ctok CHARS ; c-addr1 c-addr2' u' ctok MOVE ; -- ctok UNNEST nname <SKIP> ; ( c-addr1 u1 char --- c-addr2 u2) docode ; Not in standard, skip to first non-match pop eax ; -- c-addr u1 pop ecx ; -- c-addr1 u count to iteration register pop edx ; -- address of start of string add edx,dp ; -- add offset to base of data region, forming absolute address push edi ; -- edi preserve edi push ds ; -- edi ds pop es ; -- edi load es from ds push edx ; -- edi abs-addr1 pop edi ; -- edi load edi cld ; ascending search repe scasw ; search for non-match je skip_fail ; zero is set if no non-match was found pop eax ; -- saved di push edi ; -- abs-addr2 address after end of string, abs pop edx ; -- get it back sub edx,tchar ; -- move it back to point to non-match char sub edx,dp ; -- convert back to data-relative address push edx ; -- c-addr2 return it inc ecx ; -- c-addr2 back count up to match point push ecx ; -- c-addr2 u2 return count of remainder of string push eax ; -- c-addr2 u2 di pop edi ; -- c-addr2 u2 restore edi next skip_fail: pop eax ; saved edi push edi ; address after end of string, abs pop edx ; get it back sub edx,dp ; convert back to data-relative address push edx ; return it push ecx ; return zero which will be in ecx in this branch push eax ; that ol' saved di pop edi ; restore, -- c-addr2 u2 next nname <SCAN> ; ( c-addr1 u1 char --- c-addr2 u2) docode ; Not in Standard, point to head of substring c-addr2 u2 where char first found pop eax ; char pop ecx ; count to iteration register pop edx ; address of start of string add edx,dp ; add offset to base of data seg push edi ; save edi push ds pop es ; load es from ds push edx pop edi ; load edi cld ; ascending search repne scasw ; search for match jne scan_fail ; zero is set if char was ever found pop eax ; saved edi push edi ; address after end of string, abs pop edx ; get it back sub edx,tchar ; move it back to match char sub edx,dp ; convert back to data-relative address push edx ; return it inc ecx ; back count up to match point push ecx ; return count of remainder of string push eax ; that ol' saved edi pop edi ; restore, -- c-addr2 u2 next scan_fail: pop eax ; saved edi push edi ; address after end of string, abs pop edx ; get it back sub edx,dp ; convert back to data-relative address push edx ; return it push ecx ; return zero which will be in ecx in this branch push eax ; that ol' saved edi pop edi ; restore, -- c-addr2 u2 next fnamemanque <-TRAILING> ; c-addr1 u1 -- c-addr1 u2 fw_DASH_TRAILING: ; STRING docode mov ecx,[esp] ; count mov edx,cell[esp] ; string address add edx,ecx ; do this twice to handle wide character size add edx,ecx ; point past end of string sub edx,tchar ; point to last character in string add edx,dp ; absolute address mov ax,20h ; blank push edi ; preserve edi push edx ; end-of-string abs address pop edi ; load edi push ds pop es ; same seg, probably redundant std ; backwards search repe scasw ; seek non-match with char je none_trailing ; no non-blanks pop edi ; restore edi inc cx ; adjust count to point back to end of string mov [esp],ecx ; new count cld ; !!!***!!! important, NEXT won't work unless direction flag set this way next none_trailing: ; no non-blanks at all pop edi ; restore edi mov DWORD PTR [esp],FALSE ; zero count cld ; !!!***!!! important, NEXT won't work unless direction flag set this way next finame <SLITERAL> ; c-addr1 u Execution: -- c-addr2 u ctok NEST ; STRING ctok STATEABORT ctok ALIGN ctok DUP ; -- c-addr1 u u ctok HERE ; -- c-addr1 u u here ctok TWO_SWAP ; -- u here c-addr1 u ctok HERE ; -- u here c-addr1 u here ctok PLACE ; -- u here ctok DOLIT ctok DOSQUOTE ; -- u here xt ctok COMPCOMMA ctok COMPCOMMA ; -- u ctok ONE_PLUS ; -- u' account for count character ctok CHARS ; -- chars ctok ALLOT ; -- ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <2 or immedMask> db 'S',0,'"',0 ; Interp: "ccc<"> -- c-addr u Compile: "ccc<"> -- Execute: c-addr u align 4 ; FILE fw_S_QUOTE: ctok NEST charlit '"' ; -- char ctok PARSE ; -- c-addr u ctok STATE ; -- c-addr u a-addr ctok FETCH ; -- c-addr u flag compif s_quote1 ; are we compiling? ctok ALIGN ; for good luck -- maybe this should be removed ctok HERE ; -- c-addr1 u c-addr2 ctok DUP ; -- c-addr1 u c-addr2 c-addr2 ctok TO_R ; -- c-addr1 u c-addr2 R: -- c-addr2 ctok OVER ; -- c-addr1 u c-addr2 u R: -- c-addr2 ctok ONE_PLUS ; -- c-addr1 u c-addr2 u' R: -- c-addr2 ctok CHARS ; -- c-addr1 u c-addr2 chars R: -- c-addr2 ctok ALLOT ; -- c-addr1 u c-addr2 R: -- c-addr2 ctok PLACE ; -- R: -- c-addr2 literal 0 ctok CCOMMA ; -- null pad ctok DOLIT ctok DOSQUOTE ; -- xt R: -- c-addr2 ctok COMPCOMMA ; -- R: -- c-addr2 ctok R_FROM ; -- c-addr2 R: -- ctok COMPCOMMA ; -- ctok EXIT s_quote1: literal stringBuffer ; -- c-addr1 u c-addr2 ctok PLACE ; -- literal stringBuffer ; -- c-addr2 ctok COUNT ; -- c-addr2 u ctok TWO_DUP ctok CHARS ctok PLUS literal 0 ctok SWAP ctok C_STORE ; append null terminator ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <2 or immedMask> db '.',0,'"',0 ; Interp: -- c-addr u Compile -- align 4 ; CORE fw_DOT_QUOTE: ctok NEST ctok STATEABORT ctok DP ctok FETCH ; -- dictionary-pointer ctok S_QUOTE ; -- dp S" has stored string and embedded execution engine ctok DOLIT ctok DODOTQUOTE ctok SWAP ; -- xt dp ctok CODETODATA ctok STORE ; -- overwrite S" exe engine with ." exe engine ctok UNNEST fname <PAD> ; -- c-addr ctok DOCONST ; CORE EXT dd tickpad ;--( Number Conversion ) fname <BASE> ; a-addr ctok DOCONST ; CORE dd var_base fname <DECIMAL> ; -- ctok NEST ; CORE literal 10 ctok BASE ctok STORE ctok UNNEST fname <HEX> ; -- ctok NEST ; CORE literal 16 ctok BASE ctok STORE ctok UNNEST fname <HLD> ; a-addr ctok DOCONST ; Implementation detail dd var_hld fname <HOLD> ; char -- ctok NEST ; CORE literal -1 ctok CHARS ctok HLD ctok PL_STORE ; predecrement offset pointer which was set by <# ctok HLD ctok FETCH ctok C_STORE ; store character in numeric format buffer ctok UNNEST ; Is char a digit in base n? nname <DIGIT> ; char n1 -- n2 true | char false docode ; Not in Standard pop edx ; base pop eax ; char mov ecx,eax ; save copy of char sub ax,'0' ; is char >= '0' jb not_digit ; if not, jump not_digit cmp ax,9 ; is char <= 9 jbe digit1 ; yes, jump to digit_1 cmp ax,'A'-'0' ; no, see if it's an alpha number jb not_digit ; it ain't, jump away sub ax,'A'-'0'-10 ; it is, subtract offset of that portion of char set to make correct digit digit1: cmp ax,dx ; now compare resultant number to base jnb not_digit ; it ain't a digit if it ain't below the value of the base push eax ; it is a digit, push push TRUE ; TRUE for success next not_digit: push ecx ; char xor eax,eax ; false, failure push eax next nname <DPL> ; -- a-addr ctok DOCONST ; Not in Standard dd var_dpl nname <NUMBER> ; c-addr1 u1 -- d TRUE | x x FALSE ctok NEST ; Not in Standard ctok TRUE ctok DPL ctok STORE ; indicate no dot in number input as default ctok OVER ; -- c-a1 u1 c-a1 ctok C_FETCH ; -- c-a1 u1 char charlit '-' ; -- c-a1 u1 char1 char2 ctok EQUAL ; -- c-a1 u1 flag ctok DUP ; -- c-a1 u1 flag flag ctok TO_R ; -- c-a1 u1 flag flag R: -- flag save negative flag compif number1 ; was there a prepended negative sign? ctok ONE_MINUS ; -- c-a1 u1' R: -- flag yes, dec count ctok SWAP ctok CHAR_PLUS ; -- u1' c-a1' R: -- flag advance address ctok SWAP ; -- c-a1' u1' R: -- flag number1: ctok FALSE ctok FALSE ; -- c-a1' u1' ud R: -- flag ctok TWO_SWAP ; -- ud c-a1' u1' R: -- flag number2: ctok TO_NUMBER ; -- ud c-a2 u2 R: -- flag ctok QDUP ; -- ud c-a2 [ u2 u2 | 0 ] R: -- flag compif number_success ; did number conversion complete leave non-zero count of chars left? ctok OVER ; -- ud c-a2 u2 c-a2 R: -- flag ctok C_FETCH ; -- ud c-a2 u2 char R: -- flag charlit '.' ; -- ud c-a2 u2 char1 char2 R: -- flag ctok EQUAL ; -- ud c-a2 u2 flag R: -- flag compif number_fail ; was the character which stopped the conversion a "dot"? ctok DUP ; -- ud c-a2 u2 u2 R: -- flag ctok ONE_MINUS ; -- ud c-a2 u2 u2' R: -- flag ctok DPL ; -- ud c-a2 u2 u2' a-addr R: -- flag ; right-justified count to dot-place-marker ctok STORE ; -- ud c-a2 u2 R: -- flag ctok ONE_MINUS ; -- ud c-a2 u2' R: -- flag ctok SWAP ; -- ud u2' c-a2 R: -- flag ctok CHAR_PLUS ; -- ud u2' c-a2' R: -- flag ctok SWAP ; -- ud c-a2' u2' R: -- flag ctok DUP ; -- ud c-a2' u2' R: -- flag ctok DOUNTILNOT ; more chars? try it some more! This allows multiple dots in a number ... sounds ok dd number2 ; otherwise, we're done if parsing the "dot" exhausted the string ctok DROP ; -- ud c-a2' R: -- flag compelse number_success number_fail: ; -- ud c-a u R: -- flag ctok TWO_DROP ; -- ud R: -- flag ctok FALSE ; -- ud 0 R: -- flag ctok R_FROM ; -- ud 0 flag R: -- ctok DROP ; -- ud 0 ctok EXIT ; -- x x 0 number_success: ; -- ud c-addr R: -- flag ctok DROP ; -- ud R: -- flag ctok R_FROM ; -- ud flag R: -- compif number_done ; did we mark this negative? ctok DNEGATE ; -- d number_done: ctok TRUE ; -- d true ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 7 db '>',0,'N',0,'U',0,'M',0,'B',0,'E',0,'R',0 ; ud1 c-addr1 u1 -- ud2 c-addr2 u2 fw_TO_NUMBER: ctok NEST tonum1: ctok DUP ; BEGIN -- ud1 c-addr1 u1 u1 compif tonum4 ; WHILE ctok SWAP ; -- ud1 u1 c-addr1 ctok COUNT ; -- ud1 u1 c-addr char ctok BASE ; -- ud1 u1 c-addr char a-addr ctok FETCH ; -- ud1 u1 c-addr char n ctok DIGIT ; -- ud1 u1 c-addr n flag compif tonum2 ; if it's a digit ctok TO_R ; -- ud1 u1 c-addr R: -- n ctok TWO_SWAP ; -- u1 c-addr ud1 R: -- n ctok BASE ctok FETCH ; -- u1 c-addr ud1 n R: -- n ctok UDSTARU ; -- u1 c-addr ud R: -- n ctok R_FROM literal 0 ; -- u1 c-addr ud "udx" R: -- ctok D_PLUS ; -- u1 c-addr ud' ctok TWO_SWAP ; -- ud' u1 c-addr ctok SWAP ; -- ud2 c-addr u1 compelse tonum3 ; ELSE tonum2: ctok DROP ; -- ud2 u2 c-addr literal tchar ctok MINUS ; -- ud2 u2 c-addr2 ctok SWAP ; -- ud2 c-addr2 u2 ctok EXIT ; THEN tonum3: ctok ONE_MINUS ; -- ud c-addr u compelse tonum1 ; REPEAT tonum4: ctok UNNEST ; -- ud2 c-addr2 u2 ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '<',0,'#',0 ; -- align 4 ; CORE fw_LSHARP: ctok NEST literal ticknumend ctok HLD ctok STORE ; set up pointer to numeric output string format buffer ctok UNNEST fnamemanque <#> ; ud1 -- ud2 fw_SHARP: ctok NEST ctok BASE ctok FETCH ctok DUMSLMOD ; -- r ud' ctok ROT ctok DUP literal 10 ctok LESS ; -- ud' r flag ; is this within the numeric Unicode chars? compif sharp1 ctok DOLIT db '0',0,0,0 ; -- ud' r char ; yes, we'll need to add its number to the char '0' compelse sharp2 sharp1: literal 'A'-10 ; -- ud' r char ; no we'll need to add its number to an offset from 'A' sharp2: ctok PLUS ; -- ud' char' ctok HOLD ; -- ud' ; store char ctok UNNEST fnamemanque <#S> ; ud1 -- ud2 fw_SHARPS: ctok NEST sharps: ctok SHARP ; -- ud' loop converting chars ctok TWO_DUP ; -- ud' ud' ctok OR ; -- ud' flag ctok DOUNTILNOT ; -- ud' loop until it's 0.0 dd sharps ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 2 db '#',0,'>',0 ; ud -- c-addr u align 4 ; CORE fw_SHARPR: ctok NEST ctok TWO_DROP ; -- discard what's left of double which was to be formatted ctok HLD ctok FETCH ; -- c-addr literal ticknumend ; -- c-addr1 c-addr2 ctok OVER ; -- c-addr1 c-addr2 ctok MINUS ; -- c-addr1 n literal 1 ctok CHARS ; -- c-addr1 n sizeofchar address diff has to be divided by char size ctok SLASH ; -- c-addr u ctok UNNEST ;--( I/O ) fname <CR> ; -- ctok NEST ; CORE literal 0DH ctok EMIT literal 0AH ctok EMIT ctok UNNEST fname <SIGN> ; n -- ctok NEST ; CORE ctok ZEROLT compif sign1 charlit '-' ctok HOLD sign1: ctok UNNEST fnamemanque <.> ; n -- fw_DOT: ctok NEST ; CORE ctok PDOT ctok TYPE ; -- ctok BL ctok EMIT ctok UNNEST fnamemanque <.R> ; n1 n2 -- fw_DOT_R: ctok NEST ; CORE EXT ctok SWAP ; -- n2 n1 ctok PDOT ; -- n2 c-addr u ctok ROT ; -- c-addr u n2 ctok OVER ; -- c-addr u n2 u ctok MINUS ; -- c-addr u1 u2 literal 0 ctok MAX ; -- c-addr u1 u2' ctok SPACES ; -- c-addr u ctok TYPE ; -- ctok UNNEST znamemanque <(.)> ; n -- c-addr u fw_PDOT: ctok NEST ctok DUP ; -- n n ctok ABS ; -- n _n_ ctok S_TO_D ; -- n d ctok LSHARP ; -- n d ctok SHARPS ; -- n d' ctok ROT ; -- d' n ctok SIGN ; -- d ctok SHARPR ; -- c-addr u ctok UNNEST fnamemanque <D.> ; d -- fw_D_DOT: ctok NEST ; CORE ctok TUCK ; -- dh d ctok DABS ; -- dh _d_ ctok LSHARP ; -- dh _d_ ctok SHARPS ; -- dh d' ctok ROT ; -- d' dh ctok SIGN ; -- d' ctok SHARPR ; -- c-addr u ctok TYPE ; -- ctok BL ctok EMIT ctok UNNEST fnamemanque <U.> ; u -- fw_U_DOT: ; CORE ctok NEST literal 0 ctok UD_DOT ctok UNNEST nnamemanque <UD.> ; ud -- fw_UD_DOT: ; Not in Standard ctok NEST ctok LSHARP ctok SHARPS ctok SHARPR ctok TYPE ctok BL ctok EMIT ctok UNNEST fnamemanque <U.R> ; u n -- fw_U_DOT_R: ; Not in Standard ctok NEST literal 0 ctok SWAP ctok UD_DOT_R ctok UNNEST nnamemanque <UD.R> ; ud n -- fw_UD_DOT_R: ; Not in Standard ctok NEST ctok TO_R ctok LSHARP ctok SHARPS ctok SHARPR ctok R_FROM ctok OVER ctok MINUS literal 0 ctok MAX ctok SPACES ctok TYPE ctok BL ctok EMIT ctok UNNEST fnamemanque <.S> ; i*x -- i*x fw_DOT_S: ; CORE EXT ctok NEST ctok DEPTH literal 0 ctok MAX ctok DUP literal 0 compqdo dot_s1 dot_s0: ctok DUP ctok I ctok MINUS ctok PICK ctok U_DOT comploop dot_s0 dot_s1: ctok DROP ctok UNNEST zname <DEBDOTS> ; i*j char -- i*j ctok NEST ctok EMIT ctok SPACE ctok DOT_S ctok KEY ctok DROP ctok CR ctok UNNEST fnamemanque <KEY?> ; -- flag fw_KEY_Q: ; FACILITY docode mov DWORD PTR lastError[dp],TRUE ; No windows error code has all bits set mov eax,256 ; number of records to try for per Microsoft INVOKE PeekConsoleInputW, [dp+stdIn], OFFSET FLAT:inRecArray, eax, OFFSET FLAT:numRead and eax,eax ; "C" TRUE is success jne keyq1 ; on success, continue further on push eax ; push failure jmp doLastErr ; on failure, return via set error code routine keyq1: mov ecx,[numRead] ; number of input records successfully peeked and ecx,ecx je keyq_none ; none? fergit it! mov eax,OFFSET FLAT:inRecArray keyq2: .IF (WORD PTR [eax].INPUT_RECORD.EventType == KEY_EVENT) && \ ; is it a key event? (DWORD PTR [eax].INPUT_RECORD.Event.KeyEvent.bKeyDown != 0) && \ ; a press? ((WORD PTR [eax].INPUT_RECORD.Event.KeyEvent.uChar.UnicodeChar >= 1BH) || \ ; part of char set? (WORD PTR [eax].INPUT_RECORD.Event.KeyEvent.uChar.UnicodeChar == 0DH)) jmp keyq_found ; if C-language "true", a key is down, we're done .ENDIF keyq_continue: add eax,SIZE INPUT_RECORD loop keyq2 keyq_none: ; nope push FALSE next keyq_found: ; yup push TRUE next fname <KEY> ; -- char docode ; CORE xor ecx,ecx ; clear character holder lea eax,[dp+conMode] ; in order to preserve con mode INVOKE GetConsoleMode, [dp+stdIn], eax ; let's find out what it is and eax,eax ; success is "C" TRUE jne key2 ; if GetConsoleMode succeeds, continue mov eax,UniNotAChar ; on failure, push invalid char push eax jmp doLastErr ; return to NEXT via doLastErr key2: INVOKE SetConsoleMode, [dp+stdIn], 0 ; set no echo, no line input, no window/mouse/processed and eax,eax ; success is "C" TRUE jne key3 ; if SetConsoleMode succeeds, continue mov eax,UniNotAChar ; on failure, push invalid char push eax jmp doLastErr ; return to NEXT via doLastErr key3: INVOKE ReadConsoleW, [dp+stdIn], OFFSET FLAT:lastReadConW, 1, OFFSET FLAT:numRead, 0 ; get a char and eax,eax ; "C" TRUE is success je key4 ; on failure, get error code mov DWORD PTR lastError[dp],TRUE ; success, return TRUE, no Windows error code has all bits set cmp DWORD PTR numRead,0 ; did we get any? je key3 ; loop waiting xor ecx,ecx ; clear for character mov cx,WORD PTR lastReadConW ; retrieve char, ecx ostensibly clear for now push ecx ; push to stack mov eax,conMode[dp] ; get saved console mode INVOKE SetConsoleMode, [dp+stdIn], eax ; restore previous console mode, don't worry about err here next key4: INVOKE GetLastError ; on this error, don't worry about console mode mov lastError[dp],eax ; save error return mov eax,UniNotAChar push eax next fnamemanque <EKEY?> ; -- flag fw_EKEY_Q: ; FACILITY docode mov DWORD PTR lastError[dp],TRUE ; No windows error code has all bits set mov eax,256 ; number of records to try for per Microsoft INVOKE PeekConsoleInputW, [dp+stdIn], OFFSET FLAT:inRecArray, eax, OFFSET FLAT:numRead and eax,eax ; "C" TRUE is success jne ekeyq1 ; on success, continue further on push eax ; push failure jmp doLastErr ; on failure, return via set error code routine ekeyq1: mov ecx,[numRead] ; number of input records successfully peeked and ecx,ecx je ekeyq_none ; none? fergit it! mov eax,OFFSET FLAT:inRecArray ekeyq2: cmp WORD PTR [eax].INPUT_RECORD.EventType,KEY_EVENT ; loop comparing the EventType field in each struc jne ekeyq_continue ; not a KEY_EVENT, loop cmp DWORD PTR [eax].INPUT_RECORD.Event.KeyEvent.bKeyDown,0 ; test if we have a key down jne ekeyq_found ; if C-language "true", a key is down, we're done ekeyq_continue: add eax,SIZE INPUT_RECORD loop ekeyq2 ekeyq_none: ; nope push FALSE next ekeyq_found: ; yup push TRUE next fname <EKEY> ; -- u ctok NEST ; FACILITY EXT ekey1: ctok pEKEY ; -- u flag compif ekey2 ctok EXIT ekey2: ctok DROP compelse ekey1 ; loop until got one zname <pEKEY> ; -- u flag docode mov DWORD PTR lastError[dp],TRUE ; No windows error code has all bits set lea eax,[dp+conMode] ; in order to preserve con mode INVOKE GetConsoleMode, [dp+stdIn], eax ; let's find out what it is and eax,eax ; success is "C" TRUE jne pekey_setcon ; if GetConsoleMode succeeds, continue pekey_setfail: push eax push eax ; -- u flag INVOKE GetLastError mov lastError[dp],eax ; save error return mov eax,conMode[dp] ; get saved console mode INVOKE SetConsoleMode, [dp+stdIn], eax ; restore previous console mode, don't worry about err here next pekey_setcon: INVOKE SetConsoleMode, [dp+stdIn], 0 ; set no echo, no line input, no window/mouse/processed and eax,eax ; success is "C" TRUE je pekey_setfail ; if couldn't set console mode pkey0: INVOKE ReadConsoleInputW, [dp+stdIn], OFFSET FLAT:inRecArray, 1, OFFSET FLAT:numRead and eax,eax ; "C" TRUE is success jne pekey1 ; on success, continue further on push eax ; push failure push eax ; -- u flag INVOKE GetLastError mov lastError[dp],eax ; save error return mov eax,conMode[dp] ; get saved console mode INVOKE SetConsoleMode, [dp+stdIn], eax ; restore previous console mode, don't worry about err here next pekey1: mov eax,OFFSET FLAT:inRecArray .IF WORD PTR [eax].INPUT_RECORD.EventType != KEY_EVENT jmp pekey_none ; it ain't a key event, we don't care .ENDIF .IF [eax].INPUT_RECORD.Event.KeyEvent.bKeyDown == 0 jmp pekey_none .ENDIF mov dx,[eax].INPUT_RECORD.Event.KeyEvent.wVirtualKeyCode mov cl,16 shl edx,cl mov dx,[eax].INPUT_RECORD.Event.KeyEvent.uChar.UnicodeChar push edx push TRUE ; -- u flag mov eax,conMode[dp] ; get saved console mode INVOKE SetConsoleMode, [dp+stdIn], eax ; restore previous console mode, don't worry about err here next pekey_none: push FALSE push FALSE ; -- u flag mov eax,conMode[dp] ; get saved console mode INVOKE SetConsoleMode, [dp+stdIn], eax ; restore previous console mode, don't worry about err here next fname <TYPE> ; c-addr u -- dd ftype ftype: pop eax pop edx lea edx,[edx][dp] INVOKE WriteConsoleW, [dp+stdOut], edx, eax, OFFSET FLAT:numWritten, 0 jmp SHORT doLastErr ; returns to NEXT via doLastErr fname <EMIT> dd emit emit: pop DWORD PTR [dp+outChar] lea eax,[dp+outChar] INVOKE WriteConsoleW, [dp+stdOut], eax, 1, OFFSET FLAT:numWritten,0 jmp SHORT doLastErr ; returns to NEXT via doLastErr ; Serve these I/O words to set our local LastError variable either TRUE for success or to return from LastError. doLastErr: and eax,eax ; "C" TRUE is success je dLE1 ; on failure, get error code mov DWORD PTR lastError[dp],TRUE ; success, return TRUE next ; No Windows error code has all bits set dLE1: INVOKE GetLastError mov lastError[dp],eax ; save error return next ; Calls factor (ACCEPT), then handles trailing CR/LF pair. fname <ACCEPT> ; c-addr +n1 -- +n2 ctok NEST ctok OVER ctok SWAP ; -- c-a c-a +n1 ctok PACCEPT ; -- c-a +n2' ctok DUP ; -- c-a +n2 +n2 compif accept9 ctok TWO_DUP ; -- c-a +n2 c-a +n2 ctok CHARS ctok PLUS ; -- c-a1 +n2 c-a2 literal 2 literal 0 compdo accept4 accept3: literal 1 ; -- c-a1 +n2 c-a2 1 ctok CHARS ctok MINUS ; -- c-a1 +n2 c-a2' ctok DUP ctok C_FETCH ; -- c-a1 +n2 c-a2' char ctok DUP literal 0aH ; -- c-a1 +n2 c-a2' char char 0aH ctok EQUAL ; -- c-a1 +n2 c-a2' char flag ctok SWAP ; -- c-a1 +n2 c-a2' flag char literal 0dH ; -- c-a1 +n2 c-a2' flag char 0dH ctok EQUAL ; -- c-a1 +n2 c-a2' flag1 flag2 ctok OR ; -- c-a1 +n2 c-a2' flag compif accept8 ctok BL ; -- c-a1 +n2 c-a2' 020H ctok OVER ; -- c-a1 +n2 c-a2' 020H c-a2' ctok C_STORE ; -- c-a1 +n2 c-a2' accept8: comploop accept3 accept4: ; -- c-a1 +n2 c-a2' ctok DROP ; -- c-a1 +n2 accept9: ctok NIP ; -- +n2 accept_done: ctok UNNEST znamemanque <(ACCEPT)> ; c-addr +n1 -- +n2 fw_PACCEPT: ; implementation docode pop eax and eax,eax ; positive count? jnle paccept1 ; if yes, continue further on xor eax,eax ; make a zero mov [esp],eax ; +n2 = 0 on error paccept1: push eax ; preserve count lea eax,[dp+conMode] ; in order to preserve con mode INVOKE GetConsoleMode, [dp+stdIn], eax ; let's find out what it is and eax,eax ; success is "C" TRUE jne paccept2 ; if GetConsoleMode succeeds, continue pop eax ; discard count xor eax,eax ; make a zero mov [esp],eax ; n2 = 0 on error jmp doLastErr ; return to NEXT via doLastErr paccept2: INVOKE SetConsoleMode, [dp+stdIn], ENABLE_ECHO_INPUT OR ENABLE_LINE_INPUT OR ENABLE_PROCESSED_INPUT ; set echo, line input, processed handling and eax,eax ; success is "C" TRUE jne paccept3 ; if SetConsoleMode succeeds, continue pop eax ; discard count xor eax,eax ; make a zero mov [esp],eax ; n2 = 0 on error jmp doLastErr ; return to NEXT via doLastErr paccept3: pop eax ; count pop edx ; destination add edx,dp ; abs address of destination INVOKE ReadConsoleW, [dp+stdIn], edx, eax, OFFSET FLAT:numRead,0 ; get a line of input and eax,eax ; "C" TRUE is success jne paccept4 ; on success, continue elsewhere push eax jmp doLastErr ; failure, get error code paccept4: mov DWORD PTR lastError[dp],TRUE ; success, return TRUE, no Windows error code has all bits set mov eax,DWORD PTR numRead ; how many did we get? push eax ; this is: -- +n2 mov eax,conMode[dp] ; get saved console mode INVOKE SetConsoleMode, [dp+stdIn], eax ; restore previous console mode, don't worry about err here next ;--( Data Space and the Dictionary ) zname <UNFOUND> ; -- ctok NEST ; Implementation literal -13 ctok THROW ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db "'",0 ; -- xt | abort align 4 ; CORE fw_TICK: ctok NEST ctok BL ctok WORD ctok FIND ctok ZEROEQ compif tick1 ctok UNFOUND tick1: ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <3 or immedMask> db '[',0,"'",0,']',0 ; -- | abort align 4 ; CORE fw_BRACKETTICK: ctok NEST ctok STATEABORT ctok TICK ctok LITERAL ctok UNNEST fname <ALIGN> ; -- ctok NEST ; CORE literal cell ; -- 4 ctok HERE ; -- 4 addr literal cell-1 ; -- 4 addr 3 ctok AND ; -- 4 xx ctok DUP ; -- 4 xx xx compif align1 ; -- 4 xx "extra bits" indicating cell alignment? ctok MINUS ; -- n address now aligned, but a cell short ctok ALLOT ; -- now it's ok ctok EXIT align1: ctok TWO_DROP ; 4 xx -- ctok UNNEST fname <ALIGNED> ; addr -- a-addr ctok NEST ; CORE ctok DUP ; -- a a literal cell-1 ; -- a a n ctok AND ; -- a x ctok DUP ; -- a x x compif aligned1 ; -- a x "extra bits" indicating cell alignment? ctok MINUS ; -- a-a' address now aligned, but a cell short literal cell ; -- a-a' n ctok PLUS ; -- a-a ctok EXIT aligned1: ; -- a-a x no "extra bits" ctok DROP ; -- a-a ctok UNNEST fname <ALLOT> ; n -- dd allot ; CORE allot: pop eax add datap[dp],eax next fnamemanque <CELL+> ; a-addr1 -- a-addr2 fw_CELL_PLUS: ; CORE dd cell_plus cell_plus: add DWORD PTR [esp],cell next fname <CELLS> ; n1 -- n2 ctok NEST ; CORE literal cell ctok STAR ctok UNNEST fnamemanque <FORTH-WORDLIST> ; -- wid fw_FWORDLIST: ; SEARCH ctok DOKWORDLIST dd flinkp ; pointer to data address of of last word added to list dd 0 ; token of next wordlist in link fnamemanque <INTERNALS-WORDLIST> ; -- wid fw_ZWORDLIST: ; Implementation ctok DOKWORDLIST dd zlinkp ; pointer to data address of of last word added to list ctok FWORDLIST ; token of next wordlist in link fnamemanque <NONSTANDARD-WORDLIST> ; -- wid fw_NWORDLIST: ; Implementation ctok DOKWORDLIST dd nlinkp ; pointer to data address of of last word added to list ctok ZWORDLIST ; token of next wordlist in link fnamemanque <SYSTEM-WORDLIST> ; -- wid fw_SWORDLIST: ; Implementation ctok DOKWORDLIST dd slinkp ; pointer to data address of of last word added to list ctok NWORDLIST ; token of next wordlist in link fname <FORTH> ; -- ctok NEST ; SEARCH EXT ctok GET_ORDER ctok QDUP compif forth1 ctok NIP ctok FWORDLIST ctok SWAP ctok SET_ORDER ctok EXIT forth1: ctok FWORDLIST literal 1 ctok SET_ORDER ctok UNNEST fnamemanque <SET-CURRENT> ; wid -- fw_SET_CURRENT: ; SEARCH docode pop DWORD PTR current[dp] ; store wid to the current compilation wordlist variable next fnamemanque <GET-CURRENT> ; -- wid fw_GET_CURRENT: ; SEARCH dd get_current get_current: push DWORD PTR current[dp] next fnamemanque <SET-ORDER> ; wid1 .. widn n -- fw_SET_ORDER: ; SEARCH ctok NEST ctok DUP literal searchOrderSize ctok GREATER ; no bogus indices, please! literal -49 ; search order overflow THROW ctok AND ctok THROW ctok DUP ctok ZEROLT literal -50 ; search order underflow THROW ctok AND ctok THROW literal searchOrderSize literal 0 compqdo set_order1 set_order0: ; loop clearing search order ctok FALSE literal searchOrder ctok I ctok CELLS ctok PLUS ctok STORE comploop set_order0 set_order1: literal 0 compqdo set_order3 ; ?DO since 0 is a legit argument set_order2: ; loop filling cells, (if any literal searchOrder ctok I ctok CELLS ctok PLUS ctok STORE comploop set_order2 set_order3: ctok UNNEST fname <WORDLIST> ; -- wid ctok NEST ; SEARCH literal unnamedHdr ctok ABSTODATA ctok COUNT ctok NAMEWORDLIST ctok UNNEST fname <MARKER> ; "<spaces>name" -- ctok NEST ; CORE EXT literal wllink ctok FETCH ; -- xt ,wordlist link contains an xt literal 0 literal 0 ; -- xt 0 0 ,mark end of wordlists literal 2 ctok PICK ; -- xt 0 0 xt ,get a copy of wordlist link marker0: ctok DUP ; -- xt0 0 0 xt xt ,check for zero compif marker1 ctok TOKENTODATA ; -- xt0 0 0 a-addr ctok CELL_PLUS ; -- xt0 0 0 a-addr' ,now we point to pointer to list pointer ctok DUP ; -- xt0 0 0 a-addr' a-addr' ctok FETCH ; -- xt0 0 0 a-addr' a-addr'' ,data address holds last word's link for this wid ctok DUP ; -- xt0 0 0 a-addr' a-addr'' a-addr'' ctok FETCH ; -- xt0 0 0 a-addr' linkp ,pointer to last word in that wordlist ctok ROT ; -- xt0 0 0 a-addr'' linkp a-addr' ctok CELL_PLUS ; -- xt0 0 0 a-addr'' linkp a-addr''' move to back link to previous wordlist ctok FETCH ; -- xt0 0 0 a-addr'' linkp xt2 compelse marker0 ; loop and keep piling them up marker1: ; we get here when we run out of wids ctok DROP ; -- xt0 0 0 a-addrn linkpn ... a-addrz linkpz ctok DP ; -- .. a-addrz linkpz a-addr ctok FETCH ; -- .. a-addrz linkpz abs-addr literal last ctok FETCH ; -- .. a-addrz linkpz abs-addr a-addr ,"last" pointer ctok ALIGN ; for good luck ctok CREATE ; now create this forgettable dictionary entry ctok DOLIT ctok DOMARKER ; runtime engine for MARKER ctok MAKEDOES ; "does" the new word to DOMARKER ctok COMMA ; save "last" pointer ctok COMMA ; save dictionary pointer marker2: ctok TWO_DUP ; -- .. a-addrz linkpz ctok COMMA ; a last-word pointer ctok COMMA ; a wid's data body address where it stores its last word pointer ctok D_ZEROEQ ; is this a zero-zero? ctok INVERT compif marker3 ; if not, we continue compelse marker2 ; this is the continuing marker3: ctok COMMA ; and there's the wordlist pointer ctok UNNEST zname <DOMARKER> ; data-address -- ctok NEST ctok DUP ; -- a-addr a-addr literal datap ; -- a-addr1 a-addr1 a-addr2 ctok STORE ; -- a-addr ctok DUP ; -- a-addr a-addr ctok FETCH ; -- a-addr linkp literal last ; -- a-addr1 linkp a-addr2 ,restore "last" pointer ctok STORE ; -- a-addr ctok CELL_PLUS ; -- a-addr' ,go to next cell ctok DUP ; -- a-addr a-addr ctok FETCH ; -- a-addr dp ctok DP ; -- a-addr1 dp a-addr2 ,restore dictionary pointer ctok STORE ; -- a-addr ctok CELL_PLUS ; -- a-addr' domarker0: ctok DUP ; -- a-addr a-addr ,here we go for the wordlists ctok TWO_FETCH ; -- a-addr wid-body last-word ctok TWO_DUP ; -- a-addr wid-body last-word wid last-word ctok OR ; -- a-addr wid-body last-word flag compif domarker1 ; we're done if it's zero-zero ctok SWAP ; -- a-addr last-word wid-body ctok STORE ; -- a-addr ,restore a wordlist's last pointer ctok CELL_PLUS ; -- '' ctok CELL_PLUS ; -- a-addr''' ,our next fetch will be two cells ahead compelse domarker0 ; and do it again domarker1: ; we're done restoring wids ctok TWO_DROP ; -- a-addr ,we didn't use the last (null) pair ctok CELL_PLUS ; -- a-addr' ctok CELL_PLUS ; -- a-addr' (past the last NULL wordlist pair we used to mark end) ctok FETCH ; -- wid , get the wordlist link literal wllink ; -- wid a-addr ctok STORE ; -- we're done ctok UNNEST nname <NAMEWORDLIST> ; c-addr u -- wid ctok NEST ctok HEADER ; make (possibly headerless) header ctok LINKIT ; ... and link it in current wordlist ctok DP ctok FETCH ; save dictionary pointer to convert to token for this wordlist ctok DOLIT ctok DOKWORDLIST ; embed wordlist engine ctok COMPCOMMA ctok HERE ; pointer to the link pointer for this wordlist ctok COMPCOMMA literal 1 ctok CELLS ctok ALLOT ; allot storage for that link pointer literal wllink ctok FETCH ctok COMPCOMMA ; compile back pointer to previous wordlist ctok MAKETOKEN ; convert that dictionary pointer sitting on the stack to a user token ctok DUP ; save copy literal wllink ctok STORE ; store that token in the wordlist link pointer as last wordlist added ctok EXECUTE ; return own WID ctok UNNEST nname <WORDLISTS> ; -- ctok NEST ; Not in Standard ctok CR literal wlHdr ctok ABSTODATA ctok COUNT ctok TYPE literal wllink wordlists1: ctok FETCH ; -- xt, token of wordlist ctok QDUP ; -- xt xt|- compif wordlists2 ; -- xt ctok TOKENTODATA ; -- a-addr ctok DATATOABS ; -- abs-addr, convert for printing wid as it is ctok CELL_PLUS ; -- abs-addr', the wid is the abs addr of the cell past cfa ctok DUP ; -- abs abs ctok DOT_WID ; -- abs ctok SPACE ctok CELL_PLUS ; -- abs-addr of wordlist link pointer ctok ABSTODATA ; -- a-addr, read for next go-round compelse wordlists1 wordlists2: ; -- ctok CR ctok UNNEST fname <WORDS> ; -- ctok NEST ; TOOLKIT ctok CR literal searchOrder ctok FETCH ; -- wid ctok ABSTODATA ; -- addr of pointer to thread ctok FETCH ; -- addr of thread words1: ctok FETCH ; -- link-token ctok QDUP ; is it null compif words5 ; if null, we're done ctok DUP ; -- lt lt ctok DOT_WORD ; -- lt ctok TOKENTODATA ; -- a-addr ctok KEY_Q ; -- a-addr flag, has user punched for quick exit or pause? compif words1 ; -- a-addr, if no keypress, loop again words2: ; -- a-addr, here's where we get if there was a keypress ctok KEY ; -- a-addr char ctok BL ; -- a-addr c1 c2 ctok EQUAL ; -- a-addr flag, was it a space bar? compif words4 ; -- a-addr, if not, it's a quit. words3: ; -- a-addr, it was a space bar ctok KEY ; -- a-addr char, we waited for user to punch again ctok BL ; -- a-addr c1 c2 ctok NEQUAL ; -- a-addr flag, if it's a space bar, resume compif words1 ; -- a-addr, but if it's anything else, quit words4: ; -- a-addr, we fall thru here if key was NEQUAL to a space bar ctok DROP ; -- , discard address, quick exit words5: ctok CR ; -- , new line ctok UNNEST fnamemanque <GET-ORDER> ; ( -- wid1 .. widn n) fw_GET_ORDER: ; SEARCH ctok NEST literal 0 ; holder, -- 0 literal searchOrderSize ; -- 0 n literal 0 ; -- 0 n 0 compqdo get_order2 get_order0: ; -- 0 literal searchOrder ; -- 0 a-addr ctok I ; -- 0 a-addr n ctok CELLS ; -- 0 a-addr n' ctok PLUS ; -- 0 a-addr' ctok FETCH ; -- 0 wid ctok ZEROEQ ; -- 0 flag compif get_order1 ctok LEAVE ; -- 0 get_order1: ctok ONE_PLUS ; -- 0+1 comploop get_order0 get_order2: ctok DUP ; -- index index literal 0 ; -- index index 0 compqdo get_order4 get_order3: ; -- index ctok DUP ; -- index index ctok ONE_MINUS ; -- index index' ctok CELLS ; -- index n literal searchOrder ; -- index n a-addr ctok PLUS ; -- index a-addr'(last cell with a valid wid in it) ctok I ctok CELLS ctok MINUS ; -- index a-addr'' ctok FETCH ; -- index wid ctok SWAP ; -- wid index comploop get_order3 get_order4: ctok UNNEST fname <ORDER> ; -- ctok NEST ; SEARCH EXT ctok CR literal orderMsg0 ctok ABSTODATA literal orderMsg0Len ctok TYPE ; -- display text ctok GET_ORDER literal 0 compqdo order1 order0: ctok DOT_WID ; -- print each wid and its name comploop order0 order1: ctok CR ctok CR literal orderMsg1 ctok ABSTODATA literal orderMsg1Len ctok TYPE ; -- display text ctok GET_CURRENT ctok QDUP compif order2 ctok DOT_WID ; -- print each wid order2: ctok CR ctok UNNEST nnamemanque <.NAME> ; c-addr -- fw_DOT_NAME: ; Implementation ctok NEST ctok COUNT literal allNameMasks ctok INVERT ctok AND ctok TWO_DUP literal unnamedHdr ctok ABSTODATA ctok COUNT ctok COMPARE ctok ZERONE compif dot_name1 ctok TYPE ctok SPACE compelse dot_name2 dot_name1: ctok TWO_DROP dot_name2: ctok UNNEST nnamemanque <.WID> ; wid -- fw_DOT_WID: ; Implementation ctok NEST ctok CR ; one per line ctok BASE ; get and save base ctok FETCH ctok TO_R ; -- wid R: -- base ctok HEX ; switch to hex ctok DUP ; -- wid wid R: -- base literal 8 ctok U_DOT_R ; -- wid R: -- base ; print wid in hex, right justified literal widMsg ; -- wid abs-addr R: -- base ctok ABSTODATA ; data address ctok COUNT ctok TYPE ; display it ctok SPACE ; -- wid R: -- base ctok ABSTODATA ; -- a-addr R: -- base literal -1 ctok CELLS ctok PLUS ; -- a-addr of code field R: -- base ctok EXETONAME ; convert to name ctok DOT_NAME ; print it if it's got one ctok R_FROM ; -- base R: -- ctok BASE ; -- base a-addr R: -- ctok STORE ; -- ,restore base ctok UNNEST znamemanque <.WORD> ; link-token -- fw_DOT_WORD: ; Implementation ctok NEST ctok TOKENTODATA ctok LINKTONAME ctok DOT_NAME ctok UNNEST fname <ALSO> ; -- ctok NEST ; SEARCH EXT ctok GET_ORDER ctok OVER ctok SWAP ctok ONE_PLUS ctok SET_ORDER ctok UNNEST fname <PREVIOUS> ; -- ctok NEST ; SEARCH EXT ctok GET_ORDER ctok DUP literal 2 ctok LESS literal -50 ctok AND ctok THROW ; search order underflow THROW ctok NIP ctok ONE_MINUS ctok SET_ORDER ctok UNNEST fname <ONLY> ; -- ctok NEST ; SEARCH EXT ctok FWORDLIST literal 1 ctok SET_ORDER ctok UNNEST fname <DEFINITIONS> ; -- ctok NEST ; SEARCH EXT literal searchOrder ctok FETCH ctok SET_CURRENT ctok UNNEST fnamemanque <SEARCH-WORDLIST> ; c-addr u wid -- 0 | xt 1 | xt -1) fw_SEARCH_WL: ; SEARCH ctok NEST ctok ABSTODATA ; -- a-addr, of pointer to data-address ctok FETCH ; -- a-addr, data location of last link ctok FETCH ; -- ltok, last link in the wordlist search_wl0: ctok DUP ; is link to zero (end of list) compif search_wl_fail ; No, it's a real link ctok TO_R ; save copy of ltoken ctok TWO_DUP ; -- c-a u c-a u R: -- ltoken ctok R_FETCH ; -- c-a u c-a u ltoken R: -- ltoken ctok TOKENTODATA ; -- c-a u c-a u a-a R: -- ltoken ctok LINKTONAME ; -- c-a1 u c-a1 u c-a2 R: -- ltoken ctok DUP ctok TO_R ; -- c-a1 u c-a1 u c-a2 R: -- ltoken name-address ctok COUNT ; -- c-a1 u1 c-a1 u1 c-a2 u2+mask literal allNameMasks ; unmask name count byte ctok INVERT ctok AND ctok COMPARE ; -- c-a1 u1 0|1|-1 R: -- ltoken name-address ctok ZEROEQ ; -- c-a1 u1 flag R: -- ltoken name-address compif search_wl4 ; Zero? We found it ctok TWO_DROP ; -- R: -- ltoken name-address ctok R_FROM ; -- name-address R: -- ltoken ctok C_FETCH ; -- count-word+mask R: -- ltoken literal immedMask ctok AND ; -- bit R: -- ltoken compif search_wl1 literal 1 ; -- 1 R: -- ltoken compelse search_wl2 search_wl1: ; -- -1 R: -- ltoken literal -1 search_wl2: ctok R_FROM ; -- n ltoken ctok DUP ; -- n ltoken ltoken ctok TOKENTODATA ; -- n ltoken a-addr(link) ctok LINKTOEXE ; -- n ltoken a-addr' ctok DATATOABS ; -- n ltoken abs-addr ctok SWAP ; -- n a-addr' ltoken ctok USERTOKENQ ; -- n a-addr' flag compif search_wl3 ; -- is this in user dictionary? ctok ABSTOCODE ; yes, convert to code token ctok MAKETOKEN ; -- n xt search_wl3: ; -- no, abs address is valid xt for kernel words ctok SWAP ; -- xt 1|-1 ctok EXIT search_wl4: ; didn't match, -- c-a1 u1 R: -- ltoken name-address ctok R_FROM ctok DROP ; -- c-a1 u1 R: -- ltoken ctok R_FROM ; -- c-a1 u1 ltoken R: -- ctok TOKENTODATA ; -- c-a u a-addr ctok FETCH ; -- c-a u next-link-tok compelse search_wl0 ; try again search_wl_fail: ; ran out of links, -- c-a u ltoken ctok DROP ctok TWO_DROP ; -- ctok FALSE ; -- 0 ctok UNNEST fname <HERE> ; -- addr dd here ; execution engine here: push [dp+datap] ; CORE next ; Convert token such as link pointer or execution token to data-relative address zname <TOKENTODATA> ; linkt|xt -- a-addr ctok NEST ; Implementation ctok DUP ctok USERTOKENQ compif t_to_data1 ctok DETOKEN ctok CODETODATA ctok EXIT t_to_data1: ctok ABSTODATA ctok UNNEST ; All these convert from one data-relative address to another. LINK is the link address. EXE is the address ; which is represented by the execution token for the word. NAME is the count word address at the head of ; the name field, not the FFFF word before it. zname <EXETOLINK> ; a-addr1 -- a-addr2 ctok NEST ; Implementation ctok EXETONAME ctok NAMETOLINK ctok UNNEST zname <LINKTOEXE> ; a-addr1 -- a-addr2 ctok NEST ; Implementation ctok LINKTONAME ctok NAMETOEXE ctok UNNEST zname <NAMETOLINK> ; c-addr -- a-addr ctok NEST ; Implementation literal 1 ctok CHARS ctok MINUS ; back past the FFFF marker word literal 1 ctok CELLS ctok MINUS ; back to head of link field ctok UNNEST zname <LINKTONAME> ; a-addr -- c-addr ctok NEST ; Implementation literal 1 ctok CELLS ctok PLUS ; past link field literal 1 ctok CHARS ctok PLUS ; past the FFFF marker word ctok UNNEST zname <NAMETOEXE> ; c-addr -- a-addr ctok NEST ctok COUNT literal allNameMasks ctok INVERT ctok AND ; mask out all "funny" bits in count word ctok CHARS ctok PLUS ctok ALIGNED ctok UNNEST zname <EXETONAME> ; a-addr -- c-addr ctok NEST exetoname1: literal 1 ctok CHARS ctok MINUS ctok DUP ctok C_FETCH literal UniNotAChar ctok EQUAL compuntil exetoname1 ctok CHAR_PLUS ctok UNNEST ;--( Interpreter ) fname <BLK> ; -- a-addr ctok DOCONST ; CORE dd var_blk fname <FIND> ; ( c-addr -- c-addr 0 | xt 1 | xt -1 ) ctok NEST ; CORE ctok DUP ; -- $addr ctok C_FETCH ; -- $addr u compif _4find ; IF the count is non-zero literal searchOrder ; -- $addr addr literal cell ; -- $addr addr n ctok MINUS ; back up to one cell before beginning of search order array ctok SWAP ; ptr-to-wid $addr ctok FALSE ; ptr-to-wid $addr 0(place holder for DROP of SEARCH-WORDLIST result in loop) ctok FALSE ; ptr-to-wid $addr 0(place holder for DROP of DUPed flag SEARCH-WORDLIST in loop) literal searchOrderSize ; number of vocabularies in search order literal 0 compdo _3find ; loop until success or run out of search order _0find: ; -- ptr-to-wid $addr 0 0 ctok TWO_DROP ; -- ptr-to-wid $addr literal cell ; -- ptr-to-wid $addr n ctok ROT ; -- $addr n ptr-to-wid ctok PLUS ; -- ptr-to-wid $addr ctok SWAP ; -- ptw $addr ctok OVER ; -- ptr-to-wid $addr ptr-to-wid ctok FETCH ; -- ptw $addr wid|0 ctok QDUP ; we may have reached end of search order compif _1find ; -- ptw $addr wid ,valid vocabulary pointer ctok OVER ; -- ptw $addr wid $addr ctok COUNT ; -- ptw $addr wid c-addr u ctok ROT ; -- ptw $addr c-addr u wid ctok SEARCH_WL ; -- ptw $a1 [[ 0 ]|[ exetok [ -1|1 ]]] ctok DUP ; -- ptw $a1 [[ 0 0 ]|[ exetok [ -1|1 ] [-1|1]]] ctok ZEROEQ compif yfind ctok DUP ; -- ptw $a1 x1 x2 yfind: compelse _2find ; NULL in CONTEXT at this entry _1find: ; -- ptw $addr ,invalid wid ptr, end of order ctok NIP ; -- $addr ctok FALSE ; -- $addr 0 ctok UNLOOP ; -- $addr 0 ctok EXIT ; -- c-addr 0 _2find: ; -- ptw $addr x1 x2 ctok DUP ; -- ptw $addr x1 x2 x2 compif xfind ; -- ptw $addr x [-1|0|1] ctok LEAVE ; -- ptw $a1 x x xfind: comploop _0find _3find: ; -- ptw $a1 xt flag1 ctok ROT ctok DROP ; -- ptw xt flag ctok ROT ctok DROP ; -- xt flag ctok EXIT ; -- xt flag _4find: ; -- $addr the string was null ctok TRUE literal endq ; var that indicates end of input ctok STORE ctok FALSE ; -- c-addr 0 ctok UNNEST nnamemanque <?STACK> ; i*j -- i*j | - fw_QSTACK: ctok NEST ; implementation ctok SP0 ctok FETCH ; original stack pointer ctok SP_FETCH ; current stack pointer literal cell ctok PLUS ; adjusted for presence of orig. stack ptr. on stack ctok U_LESS ; has stack underflowed? compif qstack1 literal -4 ; Stack Underflow Throw ctok THROW qstack1: ctok UNNEST ; no, continue zname <INTERPRET> ; i*x -- j*x ctok NEST ; Not in Standard _0inter: ; Begin ctok QSTACK ; -- ctok BL ctok WORD ctok FIND ; -- [ 'word 0 ] | [ cfa 1|-1 ] ctok QDUP ; -- [ 'word 0 ] | [ cfa 1|-1 1|-1] compif _1inter ; -- cfa 1|-1 ctok STATE ctok FETCH ; -- cfa 1|-1 flag compif _9inter ; compiling ctok ZEROLT ; non-immediate? compif _8inter ; yes, compile it ctok COMPCOMMA ; -- compelse _0inter ; -- _8inter: ctok EXECUTE ; -- compelse _0inter ; -- _9inter: ctok DROP ; -- cfa ,interpreting ctok EXECUTE ; -- ,execute found word literal endq ctok FETCH ; -- t|f ,see if input stream exhausted compif _0inter ; -- loop if not exhausted ctok EXIT ; -- ,exhausted? exit INTERPRET _1inter: literal endq ; input stream exhausted? ctok FETCH ; -- c-addr flag compif _5inter ; if yes we're done, else we might be looking at a number ctok DROP ; discard c-addr ctok EXIT ; exit INTERPRET _5inter: ctok COUNT ; -- c-addr1 u1 ctok NUMBER ; -- d flag ctok ZEROEQ ; -- d t|f compif _zinter ; wasn't a number in current base, fail ctok UNFOUND ; show offending lexical item with "?" _zinter: ctok DPL ; -- d a-addr check for double precision ctok FETCH ; -- d [ n | -1 ] ctok TRUE ; -- d [ n | -1 ] TRUE ctok EQUAL ; -- d t|f compif _6inter ; -- ud2 ctok DROP ; -- u ,drop hi-order if not double precis ctok STATE ; -- u addr ctok FETCH ; -- u flag compif _2inter ; -- u ctok LITERAL ; -- compelse _2inter ; -- u _6inter: ctok STATE ; -- ud2 addr ctok FETCH ; -- ud2 flag compif _2inter ; -- ud2 ctok TWO_LITERAL ; -- _2inter: ; Then literal endq ctok FETCH ; -- flag compuntil _0inter ; Until ctok UNNEST fname <EVALUATE> ; i*x c-addr u -- j*x ctok NEST ctok BLK ; Save input on return stack ctok FETCH ctok TO_R ; -- i*x c-addr u R: -- BLK ctok TIB ctok TO_R ; -- i*x c-addr u R: -- BLK TIB ctok NUMTIB ctok FETCH ctok TO_R ; -- i*x c-addr u R: -- BLK TIB #TIB ctok TO_IN ctok FETCH ctok TO_R ; -- i*x c-addr u R: -- BLK TIB #TIB >IN ctok SOURCE_ID ctok FETCH ctok TO_R ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SID literal endq ctok FETCH ctok TO_R ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SID endq ctok FALSE literal endq ctok STORE ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SID endq ctok NUMTIB ctok STORE ; -- i*x c-addr R: -- BLK TIB #TIB >IN SID endq ctok TICK_TIB ctok STORE ; -- i*x R: -- BLK TIB #TIB >IN SID endq literal -1 ctok SOURCE_ID ctok STORE ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SOURCE-ID endq ctok FALSE ctok BLK ctok STORE ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SOURCE-ID endq ctok FALSE ctok TO_IN ctok STORE ; -- i*x c-addr u R: -- BLK TIB #TIB >IN SOURCE-ID endq ctok INTERPRET ; -- j*x R: -- BLK TIB #TIB >IN SOURCE-ID endq ctok R_FROM ; Restore input spec literal endq ctok STORE ; -- j*x c-addr u R: -- BLK TIB #TIB >IN SOURCE-ID ctok R_FROM ctok SOURCE_ID ctok STORE ; -- j*x c-addr u R: -- BLK TIB #TIB >IN ctok R_FROM ctok TO_IN ctok STORE ; -- j*x c-addr u R: -- BLK TIB #TIB ctok R_FROM ctok NUMTIB ctok STORE ; -- j*x c-addr u R: -- BLK TIB ctok R_FROM ctok TICK_TIB ctok STORE ; -- j*x c-addr u R: -- BLK ctok R_FROM ctok BLK ctok STORE ; -- j*x R: -- ctok UNNEST znamemanque <(PARSE)> ; char "ccc<char>" -- c-addr u fw_PPARSE: ctok NEST ; this one skips leading delims ctok SOURCE ; -- ch c-a u , get TIB or current BLOCK & char count ctok TO_IN ; -- ch c-a u a , get addr of current interp inset var ctok FETCH ; -- ch c-a u n , get current inset ctok SLSTRING ; -- ch c-a' u' ctok OVER ; -- ch c-a' u' c-a' Need a copy to increment >IN ctok TO_R ; -- ch c-a' u' R: -- c-a' ctok DUP ; -- ch c-a' u' u' R: -- c-a' ctok ZEROGT ; -- ch c-a' u' t|f R: -- c-a' compif _0parse ; -- ch c-a' u' R: -- c-a' literal 2 ; -- ch c-a' u' 2 R: -- c-a' ctok PICK ; -- ch c-a' u' ch' , copy of delim char R: -- c-a' ctok SKIP ; -- ch c-a'' u'' , skip leading delim R: -- c-a' _9parse: ctok OVER ; -- ch c-a'' u'' c-a'' R: -- c-a' ctok TO_R ; -- ch c-a'' u'' ,save adr of 1st char R: -- c-a' c-a'' ctok ROT ; -- c-a' u'' ch R: -- c-a' c-a'' ctok SCAN ; -- c-a''' u''' R: -- c-a' c-a'' ctok DROP ; -- c-a''' R: -- c-a' c-a'' ctok R_FROM ; -- c-a''' c-a'' R: -- c-a' ctok R_FROM ; -- c-a''' c-a'' c-a' R: -- literal 2 ; -- c-a''' c-a'' c-a' 2 ctok PICK ; -- c-a''' c-a'' c-a' c-a''' ctok SWAP ; -- c-a''' c-a'' c-a''' c-a' ctok MINUS ; -- c-a''' c-a'' n=bytes ctok TWO_SLASH ; -- c-a''' c-a'' n=chars ctok ONE_PLUS ; account for the character itself which was parsed to. ctok TO_IN ; -- c-a''' c-a'' n a ctok PL_STORE ; -- c-a''' c-a'' ctok TUCK ; -- c-a'' c-a''' c-a'' ctok MINUS ; -- c-addr1 bytes ctok TWO_SLASH ; -- c-addr1 u=chars compelse _1parse ; -- ch c-a u R: -- c-a _0parse: ctok R_FROM ctok DROP ; -- ch c-a u R: -- ctok DROP ; -- ch c-a ctok NIP ; -- c-a literal 0 ; -- c-a 0 _1parse: ctok UNNEST fname <PARSE> ; ( char "ccc<char>" -- c-addr u) ctok NEST ; CORE EXT, hits on leading delimiters ctok SOURCE ; -- ch c-a u , get TIB or current BLOCK & char count ctok TO_IN ; -- ch c-a u a , get addr of current interp inset var ctok FETCH ; -- ch c-a u n , get current inset ctok SLSTRING ; -- ch c-a' u' ctok OVER ; -- ch c-a' u' c-a' Need a copy to increment >IN ctok TO_R ; -- ch c-a' u' R: -- c-a' ctok DUP ; -- ch c-a' u' u' R: -- c-a' ctok ZEROGT ; -- ch c-a' u' t|f R: -- c-a' compif _0parse ; -- ch c-a' u' R: -- c-a' compelse _9parse zname <okPrompt> ; i*x -- i*x ctok NEST ; implementation ctok DOKDOTQUOTE dd okPrompt ctok DEPTH ctok DOT ctok UNNEST nnamemanque <..> ; i*x -- fw_DOTDOT: ctok NEST ctok DEPTH literal 0 compqdo dotdot2 dotdot1: ctok U_DOT comploop dotdot1 dotdot2: ctok UNNEST fname <QUIT> ; ( --) ( R: i*x --) ctok NEST ; CORE literal ticktib ctok TICK_TIB ; reset input buffer ctok STORE literal FALSE ctok BLK ; Not BLOCK input ctok STORE literal FALSE ctok SOURCE_ID ; Indicate keyboard input ctok STORE literal FALSE ctok NUMTIB ; indicate that input stream is empty ctok STORE literal FALSE ctok TO_IN ; indicate that input stream is unparsed ctok STORE literal FALSE ctok STATE ; set STATE to interpret ctok STORE literal FALSE literal inDefinition ; we're not in the middle of a : or :NONAME ctok STORE _1quit: ; this is a "begin" ctok CR ; ye olde CR each Forth QUIT literal rpzero ; zero the return stack ctok FETCH ctok RP_STORE ; init the RP stack ctok FIRSTCATCH ; set up initial catch frame literal FALSE literal endq ctok STORE ; reset end-of-input var ctok REFILL ; get a line of input compif _1quit ; loop back if no input line ctok INTERPRET ; execute it ctok STATE ; check STATE ctok FETCH ctok ZEROEQ compif _2quit ctok okPrompt ; say "ok " if interpreting _2quit: compelse _1quit ; and this is an "Again" fname <SOURCE> ; -- c-addr u ctok NEST ; CORE ctok BLK ctok FETCH ctok QDUP compif source1 ctok BLOCK literal blockSize ctok EXIT source1: ctok TIB ctok NUMTIB ctok FETCH ctok UNNEST fnamemanque <SOURCE-ID> ; -- a-addr fw_SOURCE_ID: ctok DOCONST ; CORE dd var_srcid fname <TIB> ; -- c-addr ctok NEST ; CORE EXT ctok TICK_TIB ctok FETCH ctok UNNEST ; Can't use our name header macros with this one! linkme nlinkptr countcell 4 db "'",0,'T',0,'I',0,'B',0 ; -- a-addr align 4 ; Not in Standard fw_TICK_TIB: ctok DOCONST dd var_tib fnamemanque <#TIB> ; -- c-addr fw_NUMTIB: ctok DOCONST ; CORE EXT dd var_numtib ; Can't use our name header macros with this one! linkme flinkptr countcell 3 db '>',0,'I',0,'N',0 ; -- a-addr align 4 ; CORE fw_TO_IN: ctok DOCONST dd var_to_in fname <REFILL> ; -- flag ctok NEST ; CORE EXT ctok SOURCE_ID ; check source of input ctok FETCH literal -1 ctok EQUAL ; if it's EVALUATE, exit FALSE compif refill1 ctok FALSE ctok EXIT refill1: ctok BLK ctok FETCH ; -- u ctok QDUP ; -- u u | o compif refill2 ; we get input from the next BLOCK ctok ONE_PLUS ; -- u' ctok DUP ; -- u' u' ctok BLK ; -- u' u' a-addr ctok STORE ; -- u' ctok FALSE ; Reset interpreter values ctok TO_IN ctok STORE ctok FALSE literal endq ctok STORE ctok INVALIDBLOCK ; -- flag, TRUE if invalid block number ctok ZEROEQ ; -- flag, correct sense for REFILL's return ctok EXIT refill2: ; We get input from the terminal ctok FALSE ctok TO_IN ctok STORE ; >IN OFF ctok FALSE literal endq ctok STORE ; END? OFF ctok TIB literal tibsize ctok ACCEPT ; Get as many chars as console can return ctok NUMTIB ; and store to #TIB ctok STORE ctok TRUE ctok UNNEST fname <WORD> ; ( char "ccc<char>" -- c-addr) ctok NEST ; CORE ctok PPARSE ; -- c-addr u literal wordBuffer ; -- c-addr u dest ctok TWO_DUP ; -- c-addr u dest u dest ctok SWAP ; -- src u dest dest u ctok ONE_PLUS ; -- src u dest dest u' taking the count word into account ctok CHARS ; -- src u dest dest n ctok PLUS ; -- src u dest c-addr(past end-of-dest) ctok BL ; -- src u dest c-addr bl ctok SWAP ; -- src u dest bl c-addr ctok C_STORE ; -- src u dest pad string with a blank ctok PLACE ; -- install string literal wordBuffer ; -- c-addr return word buffer addr ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <1 or immedMask> db '(',0 align 4 ; "ccc<)>" -- fw_PAREN: ; CORE ctok NEST charlit ')' ctok PARSE ctok TWO_DROP ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <1 or immedMask> db '\',0 align 4 ; "ccc<eol>" -- fw_BSLASH: ctok NEST ctok BLK ctok FETCH ; -- n compif bslash2 ctok TO_IN ctok FETCH ; -- n literal 64 ctok MOD ; -- mod ctok QDUP compif bslash1 ; -- n literal 64 ctok SWAP ctok MINUS ; -- diff ctok TO_IN ctok PL_STORE ; -- bslash1: ctok EXIT ; -- bslash2: ctok NUMTIB ; -- a-addr ctok FETCH ; -- n ctok TO_IN ctok STORE ; -- ctok UNNEST ;--( Implementation Addressing Scheme ) ; In this terminology, "Code" is the user dictionary offset from register CP, ; "Data" is the data space offset from register DP (the latter not to be confused with Forth variable DP). ; The system dictionary resides in absolute address space. ; Convert absolute address to reg DP relative offset. sname <ABSTODATA> ; abs-addr -- data-addr dd abstodata ; Implementation abstodata: sub DWORD PTR [esp],dp next ; Convert reg DP relative offset to absolute address. sname <DATATOABS> ; data-addr -- abs-addr dd datatoabs ; Implementation datatoabs: add DWORD PTR [esp],dp next ; Convert absolute address to reg CP relative offset. sname <ABSTOCODE> ; abs-addr -- code-addr dd abstocode ; Implementation abstocode: sub DWORD PTR [esp],cp next ; Convert reg CP relative offset to absolute address. sname <CODETOABS> ; code-addr -- abs-addr dd codetoabs ; Implementation codetoabs: add DWORD PTR [esp],cp next ; Convert reg CP relative code offset to reg DP relative data offset sname <CODETODATA> ; code-addr -- data-addr ctok NEST ; Implementation ctok CODETOABS ctok ABSTODATA ctok UNNEST ; Convert reg DP relative data offset to reg CP relative code offset sname <DATATOCODE> ; data-addr -- code-addr ctok NEST ; Implementation ctok DATATOABS ctok ABSTOCODE ctok UNNEST ; Convert an offset in the user dictionary to a user dict execution token zname <MAKETOKEN> ; code-offset -- user-xt ctok NEST ; Implementation detail literal userdictmask ctok OR ctok UNNEST ; Detect if a given token is from the user dictionary znamemanque <USERTOKEN?> fw_USERTOKENQ: ; xt -- flag ctok NEST literal userdictmask ctok AND ctok ZEROEQ ctok ZEROEQ ctok UNNEST ; Unmask a user dictionary token zname <DETOKEN> ; user-xt -- code-offset ctok NEST literal userdictmask ctok INVERT ctok AND ctok UNNEST ;--( Compiler ) ; Any compiler word with "xt" in the stack args presumes that a valid form of xt is present on the stack in that position. zname <SAVEDEPTH> ; i*x -- i*x ctok NEST ; Implementation ctok SP_FETCH literal cstack ctok STORE ctok UNNEST zname <CHECKDEPTH> ; j*x -- j*x [ 0 | n if stack has changed ] ctok NEST ; Implementation ctok SP_FETCH literal cstack ctok FETCH ctok MINUS ctok UNNEST zname <HEADER> ; c-addr u -- ctok NEST ; Implementation ctok DP ctok FETCH ; -- c-addr u code-offset ctok MAKETOKEN ; -- c-addr u valid-link-token literal last ; -- c-addr u valid-link-token a-addr ctok STORE ; -- c-addr u keep token for last link added to dictionary ctok GET_CURRENT ; -- c-addr u wid ctok ABSTODATA ; -- c-addr u a-addr-pointer ctok FETCH ; -- c-addr u a-addr-wordlist-data-body ctok FETCH ; -- c-addr u token ctok COMPCOMMA ; -- c-addr u compile back-link to previous definiton in wl ctok DUP ; -- c-addr u u literal 16 ctok LSHIFT ; -- c-addr u u<<16 because we are going to store two words as a dword literal 0FFFFH ; -- c-addr u u 0ffff ctok OR ; -- c-addr u 0ffffuuuu ctok COMPCOMMA ; -- c-addr u ctok DP ctok FETCH ; -- c-addr u code-offset ctok CODETODATA ; -- c-addr u a-addr ctok SWAP ; -- c-addr a-addr u ctok CHARS ; -- c-addr a-addr uchars ctok DUP ; -- c-addr a-addr ubytes ubytes ctok TO_R ; -- c-addr a-addr ubytes R: -- ubytes ctok MOVE ; -- R: -- ubytes ctok R_FROM ; -- ubytes R: -- ctok DP ctok FETCH ; -- ubytes code-offset ctok PLUS ; -- n ctok ALIGNED ; -- n' ctok DP ; -- n a-addr ctok STORE ; -- ctok UNNEST zname <LINKIT> ; -- ctok NEST ; Implementation literal last ; -- a-addr ctok FETCH ; -- ltok ctok GET_CURRENT ; -- ltok wid ctok ABSTODATA ; -- ltok a-addr-pointer-to-wordlist-databody ctok FETCH ; -- ltok a-addr-of-wordlist-databody ctok STORE ; -- ctok UNNEST ; This one's why ";" doesn't reset the system variable "nonaming" fname <IMMEDIATE> ; -- ctok NEST ; CORE literal nonaming ctok FETCH literal -32 ; zero-length string THROW ctok AND ctok THROW ; a :NONAME word can't be IMMEDIATE literal last ctok FETCH ctok TOKENTODATA ctok LINKTONAME ctok DUP ctok C_FETCH literal immedMask ctok OR ctok SWAP ctok C_STORE ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 1 db ':',0 align 4 ; "name" -- fw_COLON: ; CORE ctok NEST literal inDefinition ctok FETCH compif colon1 literal -29 ctok THROW ; nested compilation colon1: ctok TRUE literal inDefinition ; we're in a : definition now, prevent nested compilation ctok STORE ctok BL ctok WORD ctok COUNT ctok QDUP ctok ZEROEQ compif colonnzero literal -16 ctok THROW colonnzero: ctok FALSE literal nonaming ctok STORE ; this is not a :NONAME defintion ctok HEADER compelse noname1 ; continue on in :NONAME ; Can't use our name header macros with this one! linkme flinkptr countcell 7 db ':',0,'N',0,'O',0,'N',0,'A',0,'M',0,'E',0 align 4 ; -- | xt (when nonaming) fw_noname: ; CORE EXT ctok NEST ctok TRUE literal inDefinition ctok FETCH compif noname0 literal -29 ctok THROW ; nested compilation noname0: literal inDefinition ; we're in a : definition now, prevent nested compilation ctok STORE ctok TRUE literal nonaming ctok STORE ; this is a :NONAME defintion ctok DP ctok FETCH ctok MAKETOKEN literal last ctok STORE ; so semicolon knows what to put on the stack noname1: ; colon ":" jumps here ctok SAVEDEPTH ; save stack depth to be checked by ";" ctok DOLIT ctok NEST ctok COMPCOMMA ctok RBRACKET ctok UNNEST zname <STATEABORT> ; -- ctok NEST ; Implementation ctok STATE ctok FETCH ctok ZEROEQ ; state zero? we're interpreting literal -14 ; Interpreting a compile-only word throw ctok AND ctok THROW ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <immedMask or 1> db ';',0 align 4 ; -- | xt (when nonaming) fw_SEMICOLON: ; CORE ctok NEST ctok STATEABORT ctok FALSE literal inDefinition ; we're now out of a : or :NONAME ctok STORE ctok DOLIT ctok UNNEST ctok COMPCOMMA ctok LBRACKET ctok CHECKDEPTH compif semi_done literal -52 ctok THROW ctok EXIT semi_done: literal nonaming ctok FETCH compif semi_named literal last ; unnamed, get xt for last definition and leave on stack ctok FETCH ctok EXIT semi_named: ctok LINKIT ; named, link in to compilation wordlist ctok UNNEST fnamemanque <]> ; -- fw_RBRACKET: ; CORE ctok NEST ctok TRUE ctok STATE ctok STORE ctok UNNEST finamemanque <[> ; -- fw_LBRACKET: ; CORE ctok NEST ctok STATEABORT ctok FALSE ctok STATE ctok STORE ctok UNNEST fname <STATE> ; -- a-addr ctok DOCONST ; CORE dd var_state nname <DP> ; -- a-addr ctok DOCONST ; Not in Standard dd dictp ; Can't use our name header macros with this one! linkme flinkptr countcell 8 db 'C',0,'O',0,'M',0,'P',0,'I',0,'L',0,'E',0,',',0 align 4 ; xt -- fw_COMPCOMMA: ; CORE EXT ctok NEST ctok DP ; -- xt dp ctok DUP ; -- xt dp dp ctok FETCH ; -- xt dp @dp ctok ALIGNED ; -- xt dp @dp' ctok ROT ; -- dp @dp' xt ctok OVER ; -- dp @dp' xt @dp' ctok CODETODATA ; -- dp @dp' xt a-addr ctok STORE ; -- dp @dp' ctok CELL_PLUS ; -- dp @dp'' ctok SWAP ; -- @dp'' dp(a-addr) ctok STORE ; -- ctok UNNEST finame <RECURSE> ; -- ctok NEST ; CORE ctok STATEABORT literal last ctok FETCH ctok TOKENTODATA ctok LINKTOEXE ctok DATATOCODE ctok MAKETOKEN ctok COMPCOMMA ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell 5 db '>',0,'B',0,'O',0,'D',0,'Y',0 align 4 ; xt -- a-addr fw_TO_BODY: ; CORE ctok NEST ctok TOKENTODATA ; -- a-addr ctok DUP ; -- a-addr a-addr ctok FETCH ; -- a-addr xt2 ctok DUP ; -- a-addr xt2 xt2 ctok DOLIT ctok DOCONST ; -- a-addr xt2 xt2 xt3 ctok EQUAL ; -- a-addr xt2 flag ctok SWAP ; -- a-addr flag xt2 ctok DUP ; -- a-addr flag xt2 xt2 ctok DOLIT ctok DODOES ; -- a-addr flag xt2 xt2 xt4 ctok EQUAL ; -- a-addr flag1 xt2 flag2 ctok SWAP ; -- a-addr flag1 flag2 xt2 ctok DOLIT ctok DODEFER ; -- a-addr flag1 flag2 xt2 xt5 ctok EQUAL ; -- a-addr flag1 flag2 flag3 ctok OR ; -- a-addr flag1 flag4 ctok OR ; -- a-addr flag ctok ZEROEQ ; -- a-addr ~flag compif to_body1 literal -31 ctok THROW to_body1: ctok CELL_PLUS ; -- a-addr' ctok FETCH ; -- a-addr'' ctok UNNEST fname <CREATE> ; "name" -- ctok NEST ; CORE ctok ALIGN ctok BL ctok WORD ctok COUNT ctok QDUP ctok ZEROEQ compif create1 literal -16 ctok THROW create1: ctok HEADER ctok DOLIT ctok DOCONST ctok COMPCOMMA ctok HERE ctok COMPCOMMA ctok LINKIT ctok UNNEST fname <VARIABLE> ; "name" -- ctok NEST ; CORE ctok CREATE literal 1 ctok CELLS ctok ALLOT ctok UNNEST fname <CONSTANT> ; x "name" -- ctok NEST ; CORE ctok CREATE ctok DP ctok FETCH ctok CODETODATA literal 1 ctok CELLS ctok MINUS ctok STORE ctok UNNEST zname <MAKEDOES> ; xt -- ctok NEST ; Implementation ctok DOLIT ctok DODOES literal last ; Link token left by the execution of CREATE ctok FETCH ctok TOKENTODATA ctok LINKTOEXE ; Link token is now data address of execution vector ctok STORE ; Now execution vector of CREATEd word is overwritten with DODOES ctok COMPCOMMA ; compile the xt for the DOES> body ctok UNNEST ; Can't use our name header macros with this one! linkme flinkptr countcell <5 or immedMask> db 'D',0,'O',0,'E',0,'S',0,'>',0 align 4 ; -- fw_DOES: ; CORE ctok NEST ctok DOLIT ctok DOLIT ctok COMPCOMMA ; we are laying down a literal ctok DP ctok FETCH literal 3 ctok CELLS ctok PLUS ; the literal is the dict pointer plus the cells laid down by DOES> .. ctok COMPCOMMA ; .. up to the code laid down in the DOES> body. ctok DOLIT ctok MAKETOKEN ctok COMPCOMMA ; Then MAKETOKEN has to be executed on that literal at DOES> time ctok DOLIT ctok MAKEDOES ; Resultant xt is consumed by MAKEDOES ctok COMPCOMMA ctok DOLIT ctok EXIT ctok COMPCOMMA ; Then we EXIT the CREATE .. DOES> definition but continue to compile ctok UNNEST finame <LITERAL> ; x -- ctok NEST ; CORE ctok DOLIT ctok DOLIT ctok COMPCOMMA ctok COMPCOMMA ctok UNNEST finamemanque <2LITERAL> ; x x -- fw_TWO_LITERAL: ; DOUBLE ctok NEST ctok DOLIT ctok DODLIT ctok COMPCOMMA ctok COMPCOMMA ctok COMPCOMMA ctok UNNEST finame <POSTPONE> ; "name" -- ctok NEST ; CORE ctok STATEABORT ctok BL ctok WORD ctok FIND ctok DUP ctok ZEROEQ compif postpone1 ctok UNFOUND postpone1: ctok DOLIT ; first of all, compile this code here .. ctok STATEABORT ; ... since .. ctok COMPCOMMA ; ... the POSTPONEd construct should THROW -14 if encountered interpretively. ctok ZEROLT ; -1 is non-IMMEDIATE compif postpone2 ctok LITERAL ctok DOLIT ctok COMPCOMMA ctok COMPCOMMA ctok EXIT postpone2: ; 1 is IMMEDIATE ctok COMPCOMMA ctok UNNEST ;--( Branches ) zname <UNRESOLVED> ; -- ctok NEST ; Implementation literal -22 ctok THROW finame <IF> ; -- orig ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOIF ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- orig ctok DOLIT ctok UNRESOLVED ; -- orig xt ctok COMPCOMMA ; -- orig ctok UNNEST finame <ELSE> ; orig1 -- orig2 ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOELSE ; -- o1 xt ctok COMPCOMMA ; -- o1 ctok DP ctok FETCH ; -- o1 o2 ctok SWAP ; -- o2 o1 ctok DOLIT ctok UNRESOLVED ; -- o2 o1 xt ctok COMPCOMMA ; -- o2 o1 ctok DP ctok FETCH ; -- o2 o1 resolution ctok MAKETOKEN ; -- o2 o1 xt ctok SWAP ; -- o2 xt o1 ctok CODETODATA ; -- o2 xt a-addr ctok STORE ; -- o2 ctok UNNEST finame <THEN> ; orig -- ctok NEST ; CORE ctok STATEABORT ctok DP ctok FETCH ; -- orig resolution ctok MAKETOKEN ; -- orig xt ctok SWAP ; -- xt orig ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST finame <BEGIN> ; -- dest ctok NEST ; CORE ctok STATEABORT ctok DP ctok FETCH ; -- dest ctok UNNEST finame <UNTIL> ; dest -- ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOUNTIL ; -- dest xt ctok COMPCOMMA ; -- dest ctok MAKETOKEN ; -- xt ctok COMPCOMMA ; -- ctok UNNEST finame <WHILE> ; dest -- orig dest ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOIF ; -- dest xt ctok COMPCOMMA ; -- dest ctok DP ctok FETCH ; -- dest orig ctok SWAP ; -- orig dest ctok DOLIT ctok UNRESOLVED ; -- orig dest xt ctok COMPCOMMA ; -- orig dest ctok UNNEST finame <REPEAT> ; orig dest -- ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOELSE ; -- o d xt ctok COMPCOMMA ; -- o d ctok MAKETOKEN ; -- o xt ctok COMPCOMMA ; -- o ctok DP ctok FETCH ; -- o resolution ctok MAKETOKEN ; -- o xt ctok SWAP ; -- xt orig ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST finame <AGAIN> ; dest -- ctok NEST ; CORE EXT ctok STATEABORT ctok DOLIT ctok DOELSE ; -- d xt ctok COMPCOMMA ; -- d ctok MAKETOKEN ; -- xt ctok COMPCOMMA ; -- ctok UNNEST finame <DO> ; -- do-dest ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DODO ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- do-dest ctok DOLIT ctok UNRESOLVED ; -- do-dest xt ctok COMPCOMMA ; -- do-dest ctok UNNEST finamemanque <?DO> ; -- dest fw_QDO: ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOQDO ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- do-dest ctok DOLIT ctok UNRESOLVED ; -- do-dest xt ctok COMPCOMMA ; -- do-dest ctok UNNEST finame <LOOP> ; dest -- ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOLOOP ; -- dest xt ctok COMPCOMMA ; -- dest ctok DUP ; -- dest dest ctok CELL_PLUS ; -- dest dest' so that it points beyond UNRESOLVED ctok MAKETOKEN ; -- dest xt ctok COMPCOMMA ; -- dest ctok DP ctok FETCH ; -- dest resolution ctok MAKETOKEN ; -- dest xt ctok SWAP ; -- xt dest ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST finamemanque <+LOOP> ; -- fw_PLUSLOOP: ctok NEST ; CORE ctok STATEABORT ctok DOLIT ctok DOPLUSLOOP ; -- dest xt ctok COMPCOMMA ; -- dest ctok DUP ; -- dest dest ctok CELL_PLUS ; -- dest dest' so that it points beyond UNRESOLVED ctok MAKETOKEN ; -- dest xt ctok COMPCOMMA ; -- dest ctok DP ctok FETCH ; -- dest resolution ctok MAKETOKEN ; -- dest xt ctok SWAP ; -- xt dest ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST fname <I> ; -- n|u docode ; CORE mov eax,[rp] ; Calculate current loop index add eax,cell[rp] push eax next fname <J> ; -- n|u docode ; CORE mov eax,(3*cell)[rp] ; Calculate next outermost loop index add eax,(4*cell)[rp] push eax next fname <LEAVE> docode ; -- R: loop-sys -- poprp ; CORE poprp poprpto ip next fname <UNLOOP> ; -- R: loop-sys -- docode ; CORE poprp poprp poprp next ;--( Exception Handling ) fname <ABORT> ; -- ctok NEST ; CORE ctok TRUE ctok THROW ; no unnest needed! ; Can't use our name header macros with this one! linkme flinkptr countcell <6 or immedMask> db 'A',0,'B',0,'O',0,'R',0,'T',0,'"',0 ; ccc<"> -- align 4 ; CORE fw_ABORT_QUOTE: ctok NEST ctok STATEABORT ctok DOLIT ctok DOIF ; -- xt ctok COMPCOMMA ; -- ctok DP ctok FETCH ; -- orig ctok DOLIT ctok UNRESOLVED ; -- orig xt ctok COMPCOMMA ; -- orig literal -2 ctok LITERAL ctok DP ctok FETCH ctok S_QUOTE ctok CODETODATA ctok DOLIT ctok THROW ctok SWAP ctok STORE ; overwrite the S" execution engine ctok DP ctok FETCH ; -- orig resolution ctok MAKETOKEN ; -- orig xt ctok SWAP ; -- xt orig ctok CODETODATA ; -- xt a-addr ctok STORE ; -- ctok UNNEST fname <CATCH> ; i*x xt -- j*x 0 | i*x n) dd catch ; EXCEPTION catch: pop wp ; execution token fetch edx,lastCatch ; save previous catch pointer pushrp edx ; (1) pushrp esp ; (2) save stack pointer fetch edx,var_tib ; save buffer address pushrp edx ; (3) fetch edx,var_numtib ; save number of chars in input buffer pushrp edx ; (4) fetch edx,var_to_in ; save index into input buffer pushrp edx ; (5) fetch edx,var_srcid ; save source id pushrp edx ; (6) fetch edx,var_blk ; save BLK pushrp edx ; (7) pushrp ip ; (8) save interpretive pointer store lastCatch,rp ; put pointer to this frame in lastCatch variable mov ecx,OFFSET FLAT:uncatch ; routine to recover mov ip,ecx innext ; eax (the wp) already has the token to execute align cell uncatch: ; we only end up here if no THROW intervenes docode ; as if it was a cell in a colon definition pointing to ... docode ; ... a definition which started here ... fetch rp,lastCatch ; restore return pointer from lastCatch, points to frame poprpto ip ; (8) restore IP that was stashed by CATCH poprp ; (7) discard BLK poprp ; (6) discard SOURCE-ID poprp ; (5) discard >IN poprp ; (4) discard #TIB poprp ; (3) discard 'TIB poprp ; (2) discard DSP poprpto eax ; (1) lastCatch store lastCatch,eax xor eax,eax push eax ; 0 return says all is well next fname <THROW> ; k*x n -- k*x | i*x n docode ; EXCEPTION pop edx ; check arg and edx,edx jne throw1 ; zero? continue harmlessly next throw1: ; arg was non-zero fetch rp,lastCatch ; set return stack back to where it was store lastCaught,ip ; save IP pointing to cell following the THROW poprpto ip ; (8) restore IP that was stashed by CATCH poprpto eax ; (7) store var_blk,eax ; restore BLK poprpto eax ; (6) store var_srcid,eax ; restore SOURCE-ID poprpto eax ; (5)) store var_to_in,eax ; restore >IN poprpto eax ; (4) store var_numtib,eax ; restore #TIB poprpto eax ; (3) store var_tib,eax ; restore 'TIB poprpto esp ; (2) restore DSP poprpto eax ; (1) store lastCatch,eax ; restore lastCatch push edx ; the throw code next zname <FIRSTCATCH> ; -- R: -- catch-sys docode ; Implementation xor edx,edx pushrp edx ; there is no previous catch to push in this case pushrp esp ; save stack pointer fetch edx,var_tib ; save buffer address pushrp edx fetch edx,var_numtib ; save number of chars in input buffer pushrp edx fetch edx,var_to_in ; save number of chars in input buffer pushrp edx fetch edx,var_srcid ; save source id pushrp edx fetch edx,var_blk ; save BLK pushrp edx mov eax,OFFSET FLAT:fw_CATCHFIRSTCATCH+cell pushrp eax ; the CATCH of last resort! store lastCatch,rp ; put pointer to this frame in lastCatch variable next ; onwards! zname <CATCHFIRSTCATCH> ; -- ctok NEST ; Implementation ctok DUP literal -2 ; The ABORT" throw ctok EQUAL compif catchfirst1 literal lastCaught ; Get IP which is pointing to pointer to string ctok FETCH ; IP ctok TOKENTODATA ctok FETCH ; data address of counted string ctok COUNT ctok TYPE compelse catchabort ; fall thru into the tail of ABORT throw catchfirst1: ctok DUP literal -1 ; The ABORT throw ctok EQUAL compif catchfirst4 catchabort: ctok SP0 ctok FETCH ctok SP_STORE ctok FIRSTCATCH ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH ctok QUIT ; just QUIT catchfirst4: ctok DUP literal -4 ctok EQUAL compif catchfirst13 ctok DOKDOTQUOTE ; stack underflow abort dd stackUnderMsg compelse catchabort ; exit via an ABORT catchfirst13: ctok DUP literal -13 ctok EQUAL compif catchfirst14 literal wordBuffer ctok COUNT ctok TYPE ctok SPACE charlit '?' ctok EMIT ctok SPACE ctok DOKDOTQUOTE ; undefined word abort dd undefinedMsg compelse catchabort ; exit via an ABORT catchfirst14: ctok DUP literal -14 ctok EQUAL compif catchfirst16 ctok DOKDOTQUOTE ; compile-only abort dd compOnlyMsg compelse catchabort ; exit via an ABORT catchfirst16: ctok DUP literal -16 ctok EQUAL compif catchfirst22 ctok DOKDOTQUOTE ; zero-length name string abort dd zeroStringMsg compelse catchabort ; exit via an ABORT catchfirst22: ctok DUP literal -22 ctok EQUAL compif catchfirst29 ctok DOKDOTQUOTE ; control structure abort dd conStructMsg compelse catchabort ; exit via an ABORT catchfirst29: ctok DUP literal -29 ctok EQUAL compif catchfirst31 ctok FALSE literal inDefinition ; reset internal var indicating : or :NONAME in progress ctok STORE ctok DOKDOTQUOTE ; >BODY on non-CREATE word dd compNestMsg compelse catchabort ; exit via an ABORT catchfirst31: ctok DUP literal -31 ctok EQUAL compif catchfirst33 ctok DOKDOTQUOTE ; >BODY on non-CREATE word dd toBodyMsg compelse catchabort ; exit via an ABORT catchfirst33: ctok DUP literal -33 ctok EQUAL compif catchfirst34 ctok DOKDOTQUOTE ; BLOCK read error dd blockReadMsg compelse catchabort ; exit via an ABORT catchfirst34: ctok DUP literal -34 ctok EQUAL compif catchfirst35 ctok DOKDOTQUOTE ; BLOCK write error dd blockWriteMsg compelse catchabort ; exit via an ABORT catchfirst35: ctok DUP literal -35 ctok EQUAL compif catchfirst37 ctok DOKDOTQUOTE ; BLOCK number error dd blockNumMsg compelse catchabort ; exit via an ABORT catchfirst37: ctok DUP literal -37 ctok EQUAL compif catchfirst49 ctok LastError ctok FETCH ; Error should be in LastError if we reach this point ctok DOKDOTQUOTE ; File I/O exception dd fileIOMsg ; this message needs a trailing space! ctok U_DOT ; Display compelse catchabort ; exit via an ABORT catchfirst49: ctok DUP literal -49 ; search order overflow THROW ctok EQUAL compif catchfirst50 ctok DOKDOTQUOTE dd srchOverMsg compelse catchabort ; exit via an ABORT catchfirst50: ctok DUP literal -50 ; search order underflow THROW ctok EQUAL compif catchfirst52 ctok DOKDOTQUOTE dd srchUnderMsg compelse catchabort ; exit via an ABORT catchfirst52: ctok DUP literal -52 ctok EQUAL compif catchfirst56 ctok DOKDOTQUOTE dd cStackMsg ; control flow stack changed compelse catchabort ; exit via ABORT catchfirst56: ctok DUP literal -56 ctok EQUAL compif catchall ctok DROP ; drop the -56 ctok FIRSTCATCH ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH ctok QUIT ; just QUIT catchall: ; the catch-all case for THROWs outside those we have handled literal throwMsg ctok ABSTODATA literal throwMsgLen ctok TYPE ctok DOT charlit '@' ctok EMIT ctok SPACE literal lastCaught ctok FETCH literal cell ctok MINUS ctok DOT ctok FIRSTCATCH ; if we hit the LASTCATCH frame, SP=SP0, RP=RP0, etc, just rebuild LASTCATCH ctok QUIT ctok UNNEST ;--( Tools & Utilities ) nname <NOOP> ; -- docode ; Doesn't appear in Standard nop next zname <DUMPLINE> ; a-addr1 -- a-addr2 ctok NEST ctok DUP ctok DUP ; -- a-addr1 a-addr1 ctok FALSE ctok LSHARP ; -- a-addr1 ud literal 8 ctok FALSE compdo dumpline2 dumpline1: ctok SHARP ; -- a-addr1 ud' comploop dumpline1 dumpline2: ctok SHARPR ctok TYPE ; -- a-addr1 print line address ctok SPACE literal 8 literal 0 compdo dumpline4 dumpline3: ; -- addr addr ctok COUNT ; -- addr addr' char ctok FALSE ctok LSHARP ctok SHARP ctok SHARP ctok SHARP ctok SHARP ctok SHARPR ctok TYPE ; -- addr addr' print two bytes as a word ctok SPACE comploop dumpline3 dumpline4: ctok DROP ; -- addr literal 8 literal 0 compdo dumpline6 dumpline5: ctok COUNT literal 0FFh ctok AND ctok DUP literal 01fH ; -- addr' char char 01fh ctok GREATER compif dumplinenochar ctok EMIT compelse dumplinez dumplinenochar: ctok DROP charlit '.' ctok EMIT dumplinez: comploop dumpline5 dumpline6: ctok UNNEST ; -- addr' fname <DUMP> ; addr u -- ctok NEST ; TOOLKIT ctok BASE ; -- addr u a-addr ctok FETCH ; -- addr u n ctok TO_R ; -- addr u R: -- base ctok HEX ctok CR literal dumpHdr ; print a header here ctok ABSTODATA ctok COUNT ctok TYPE ; -- addr u R: -- base ctok CR ctok SWAP ; -- u addr ctok FALSE ; -- u addr 0 literal 16 ; Now align the dump region ctok UMSLMOD ; -- u1 u2r addr/8 ctok SWAP ; -- u addr/8 u2r ctok TO_R ; -- u addr/8 R: -- u2r literal 16 ctok UMSTAR ; -- u addr' 0 R: -- u2r ctok DROP ; -- u addr' R: -- u2r ctok SWAP ; -- addr u R: -- u2r ctok FALSE ; -- addr u 0 R: -- u2r literal 16 ctok UMSLMOD ; -- addr u1r u2q R: -- u2r ctok SWAP ; -- addr u2q u1r R: -- u2r ctok ZERONE ; -- addr u/16 [-1 | 0] R: -- u2r ctok NEGATE ; -- addr u/16 [1 | 0] R: -- u2r ctok PLUS ; -- addr u(number of iterations) R: -- u2r ctok R_FROM ; -- addr u/16 u2r R: -- ctok ZERONE ; -- addr u/16 [1|0] [-1 | 0] ctok NEGATE ; -- addr u/16 [1|0] [1 | 0] ctok PLUS ; -- addr u(number of iterations) ; add line if bytes modded ctok FALSE ; -- addr u/16 0 compdo dump3 ; dump that many lines dump1: ctok DUMPLINE ; -- addr' ctok CR ; -- addr' ctok KEY_Q ; -- addr' flag, has user punched for pause or quick quit? compif dumpcontinue ; -- addr', user hasn't punched for pause or quick quit ctok KEY ; -- addr' char ctok BL ; -- addr' c1 c2 ctok EQUAL ; -- addr' flag, was it a space bar? compif dump2 ; -- addr', if not, it's a quit, hit a LEAVE below ctok KEY ; -- addr' char, space bar, we wait for user to punch again ctok BL ; -- addr' c1 c2 ctok EQUAL ; -- addr' flag, if it's a space bar, resume compif dump2 ; -- addr', but if it's anything else, quit compelse dumpcontinue ; -- addr, twas a space bar, continue dump2: ctok LEAVE ; -- addr dumpcontinue: comploop dump1 dump3: ; -- addr R: -- +n ctok DROP ; -- ctok R_FROM ; -- +n R: -- ctok BASE ; -- +n a-addr ctok STORE ; -- ctok UNNEST fname <BYE> ; -- dd byebye ; TOOLKIT EXT byebye: ; exit program fetch ebp,ntConEBP fetch esp,ntConESP fetch eax,memHandle INVOKE LocalFree, eax INVOKE WriteConsoleW, [dp+stdErr], OFFSET FLAT:byeMsg, byeMsgLen, OFFSET FLAT:numWritten,0 pop edi pop esi pop ebx leave INVOKE ExitProcess, 0 fnamemanque <AT-XY> ; u1 u2 -- fw_AT_XY: ; FACILITY docode pop eax ; y pop edx ; x shl eax,16 mov ax,dx ; compose COORD wherein Y is higher in mem than X INVOKE SetConsoleCursorPosition, DWORD PTR stdOut[dp], eax and eax,eax ; success is "C" TRUE ; je at_xy1 ; if failure, we'll do some more work mov DWORD PTR lastError[dp],-1 ; success, set lastErr next ; success, exit at_xy1: jmp doLastErr ; return to NEXT via doLastErr fname <PAGE> ; -- docode ; FACILITY mov eax,20H ; character to fill with mov edx,32767 ; !!!***!!! HACK HACK HACK we have to calculate this correctly xor ecx,ecx ; Coord for fill, i.e., "0@0" INVOKE FillConsoleOutputCharacterW, DWORD PTR stdOut[dp], eax, edx, ecx, OFFSET FLAT:numWritten and eax,eax ; success is "C" TRUE ; je at_xy1 ; failure, exit re-using code above in AT-XY xor eax,eax ; make a "0@0" Coord for next call INVOKE SetConsoleCursorPosition, DWORD PTR stdOut[dp], eax and eax,eax ; success is "C" TRUE ; je at_xy1 ; failure, exit re-using code above in AT-XY mov DWORD PTR lastError[dp],-1 ; success, set lastErr next fnamemanque <ENVIRONMENT?> ; c-addr u -- false | i*x true fw_ENVQ: ; CORE ctok NEST ctok TWO_DROP ctok FALSE ; don't know nuttin' ctok UNNEST ;--( File Words ) include jx4files.a ; jax4th.asm is just getting too big! ;--( Platform-Specific Stuff ) ; Copy unicode string to asciiz string in special sys buffer, null terminates sname <ASCIIZ> ; c-addr u -- addr ctok NEST ; Not in Standard, used for syscalls that don't take unicode ctok TUCK ; -- u c-addr u ctok FALSE ; -- u c-addr u 0 compqdo asciiz2 asciiz1: ctok DUP ; -- u c-addr c-addr ctok C_FETCH ; -- u c-addr char literal asciizBuffer ; -- u c-addr char addr ctok I ctok PLUS ; -- u c-addr char addr' ctok B_STORE ; -- u c-addr ctok CHAR_PLUS ; -- u c-addr' comploop asciiz1 asciiz2: ctok DROP ; -- u literal asciizBuffer ; -- u addr ctok PLUS ; -- addr' one past end of byte string ctok FALSE ctok SWAP ; -- 0 addr' ctok B_STORE ; -- literal asciizBuffer ; -- addr buffer holding ascii byte string ctok UNNEST ; Copy ascii string to unicode string in special sys buffer, null terminates sname <UNICODE> ; b-addr u -- addr ctok NEST ; Not in Standard, used for syscalls that don't take unicode ctok TUCK ; -- u b-addr u ctok FALSE ; -- u b-addr u 0 compqdo unicode2 unicode1: ctok DUP ; -- u b-addr b-addr ctok B_FETCH ; -- u b-addr char literal asciizBuffer ; -- u b-addr char c-addr ctok I ctok CHARS ctok PLUS ; -- u c-addr char addr' ctok C_STORE ; -- u c-addr ctok ONE_PLUS ; -- u c-addr' comploop unicode1 unicode2: ctok DROP ; -- u literal asciizBuffer ; -- u addr ctok CHARS ctok PLUS ; -- addr' one past end of byte string ctok FALSE ctok SWAP ; -- 0 addr' ctok C_STORE ; -- literal asciizBuffer ; -- addr buffer holding ascii byte string ctok UNNEST sname <SYSCALL> ; abs-addr -- edx eax docode ; Call addr and return eax and edx pushrp ebx ; I'm suspicious this isn't loyally preserved pop eax call eax push edx push eax poprpto ebx ; restore next sname <GetProcAddress> ; [lpszProc | ordinal] hModule -- abs-addr | nil docode ; find a DLL function address from a null-terminated name string call GetProcAddress ; parameter if ordinal must have zero (0000h) in hi word push eax next sname <LoadLibraryEx> ; dwFlags 0 lpszLibFile -- hModule | 0 docode call LoadLibraryExW push eax test eax,0 je doLastErr ; if error, set LastError var next sname <FreeLibrary> ; hLibModule -- docode call FreeLibrary push eax test eax,0 je doLastErr ; if error, set LastError var next sname <ENABLE_LINE_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_LINE_INPUT sname <ENABLE_ECHO_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_ECHO_INPUT sname <ENABLE_PROCESSED_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_PROCESSED_INPUT sname <ENABLE_WINDOW_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_WINDOW_INPUT sname <ENABLE_MOUSE_INPUT> ; -- x ctok DOCONST ; Con Mode constant value dd ENABLE_MOUSE_INPUT sname <StdIn> ; -- a-addr ctok DOCONST ; Con stdin dd stdIn sname <StdOut> ; -- a-addr ctok DOCONST ; Con stdout dd stdOut sname <StdErr> ; -- a-addr ctok DOCONST ; Con stdErr dd stdErr sname <ConsoleMode> ; -- a-addr ctok DOCONST ; Address of Con Mode variable dd conMode ; Implementation sname <LastError> ; -- a-addr ctok DOCONST ; Address of Last Error variable dd lastError ; Implementation sname <GetConsoleMode> ; -- LastErr | TRUE docode ; Implementation lea eax,[dp+conMode] INVOKE GetConsoleMode, [dp+stdIn], eax jmp SHORT retLastErr ; returns to NEXT via doLastErr sname <SetConsoleMode> ; -- LastErr | TRUE docode ; Implementation mov eax,[dp+conMode] INVOKE SetConsoleMode, [dp+stdIn], eax jmp SHORT retLastErr ; returns to NEXT via doLastErr ; Set our local LastError variable either TRUE for success or to return from LastError, return same on stack retLastErr: and eax,eax ; "C" TRUE is success je rLE1 ; on failure, get error code mov DWORD PTR lastError[dp],TRUE ; success, return TRUE mov eax,TRUE push TRUE next ; No Windows error code has all bits set rLE1: INVOKE GetLastError mov lastError[dp],eax ; save error return push eax next ;--( Startup & Signoff ) zname <LOGIN> docode INVOKE WriteConsoleW, [dp+stdErr], OFFSET FLAT:myMsg,myMsgLen, OFFSET FLAT:numWritten, 0 next nname <ABOUT> docode INVOKE WriteConsoleW, [dp+stdErr], OFFSET FLAT:gnuMsg, gnuMsgLen, OFFSET FLAT:numWritten, 0 next nname <COLD> ctok NEST cold: ctok GetConsoleMode ; set up our variable that tracks the console input mode ctok DROP ; discard return ctok DECIMAL ; set number conversion base to decimal, set early to aid debugging ctok FALSE ctok BLK ; input is not from a BLOCK file ctok STORE ctok FALSE ctok SOURCE_ID ; input is from keyboard ctok STORE literal ticktib ctok TICK_TIB ; set up pointer to terminal input buffer ctok STORE ctok FALSE ctok NUMTIB ; no chars in terminal input buffer ctok STORE ctok FALSE ctok TO_IN ; no index into zero chars ctok STORE ctok FALSE ctok STATE ; interpreting, not compiling ctok STORE ctok FALSE literal endq ; not end of input ctok STORE ctok EMPTYBUFFERS ; clear block buffer(s) ctok FALSE literal blockFile ctok STORE ; no active block file ctok FIRSTCATCH ; set up initial catch frame ctok INITDEFERS ; all the deferred words ctok ONLY ; set default search order ctok DEFINITIONS ; set default compilation order ctok SWORDLIST ctok NWORDLIST ctok FWORDLIST literal 3 ctok SET_ORDER cold1: ctok LSHARP ; set up number conversion buffer ctok GETCOMMANDLINE ; -- c-addr u ctok NUMTIB ctok STORE ctok TICK_TIB ctok STORE ctok BL ctok WORD ctok DROP ; -- , eliminate filename from command line ctok INTERPRET ; -- interpret, ABORT will clean up ; ctok PAGE ctok LOGIN ; display signon message including copyright ctok ABOUT ctok okPrompt ctok QUIT zname <INITDEFERS> ; -- , init all deferred vectors ctok NEST ctok DOLIT ctok FILEPOSITIONW ctok DOLIT ctok FILEPOSITION ctok TO_BODY ctok STORE ; Init FILE-POSITION ctok DOLIT ctok FILESIZEW ctok DOLIT ctok FILESIZE ctok TO_BODY ctok STORE ; Init FILE-SIZE ctok DOLIT ctok READFILEW ctok DOLIT ctok READFILE ctok TO_BODY ctok STORE ; Init READ-FILE ctok DOLIT ctok REPOFILEW ctok DOLIT ctok REPOFILE ctok TO_BODY ctok STORE ; Init REPOSITION-FILE ctok DOLIT ctok RESIZEFILEW ctok DOLIT ctok RESIZEFILE ctok TO_BODY ctok STORE ; Init RESIZE-FILE ctok DOLIT ctok WRITEFILEW ctok DOLIT ctok WRITEFILE ctok TO_BODY ctok STORE ; Init WRITE-FILE ctok UNNEST ;--( Save and Restore Input ) fnamemanque <SAVE-INPUT> ; -- xn .. x1 n fw_SAVEINP: ; CORE EXT ctok NEST ctok TIB ctok NUMTIB ctok FETCH ctok TO_IN ctok FETCH literal endq ctok FETCH ctok BLK ctok FETCH ctok SOURCE_ID ctok FETCH literal 6 ctok UNNEST fnamemanque <RESTORE-INPUT> ; -- xn .. x1 n fw_RESTINP: ; CORE EXT ctok NEST ctok DROP ctok SOURCE_ID ctok STORE ctok BLK ctok STORE literal endq ctok STORE ctok TO_IN ctok STORE ctok NUMTIB ctok STORE ctok TICK_TIB ctok STORE ctok UNNEST ;--( Saving and Restoring Images ) nnamemanque <SAVE-FORTH> ; -- 0|error fw_SAVEFORTH: docode store var_tib,ticktib ; loaded image comes back with normal inputbuff store var_numtib,0 ; loaded image comes back with no chars in buffer store var_to_in,0 ; no words parsed store endq,0 ; nuttin' happenin' store var_blk,0 ; no block store var_srcid,0 ; no file store lastError,0 ; no error store zeroBuffer,002E002Ah ; init file title string to "*.*\0" store (zeroBuffer+cell),0000002Ah mov eax,zeroBuffer ; data address of buffer add eax,dp ; convert to abs address mov edx,OFFSET FLAT:saveFile ; address of OPENFILENAME struct mov [edx].OPENFILENAME.lpstrFile,eax ; init w/ptr to string INVOKE GetSaveFileNameW,edx ; get string of file name to save and eax,eax je saveferr mov eax,zeroBuffer ; data address of buffer add eax,dp ; convert to abs address INVOKE CreateFileW, eax, GENERIC_WRITE, 0, OFFSET FLAT:secAttrib, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 cmp eax,INVALID_HANDLE_VALUE je saveferr1 ; if handle is invalid, branch away push eax ; save file handle INVOKE WriteFile, eax, cp, defDataSize+defDictSize, OFFSET FLAT:numRead, 0 and eax,eax ; did we write ok? jne saveforth1 ; if TRUE, it's ok, branch onwards INVOKE GetLastError ; if FALSE, error, get it mov edx,eax ; save the error store lastError,eax ; keep copy in lastError pop eax ; get back file handle push edx ; here's the last error return to exit word with INVOKE CloseHandle,eax ; close the file handle next ; return that error code we left on stack saveforth1: ; we wrote ok pop eax ; get file handle back INVOKE CloseHandle,eax ; close the file handle saveforthdone: xor eax,eax ; make a zero, we don't care what CloseHandle did push eax ; return success next saveferr: store lastError, userErr ; an error code that no Windows API returns INVOKE CommDlgExtendedError ; get dialog error push eax ; push error ior ; but don't store in lastError, shows diff from GetLastError next saveferr1: INVOKE GetLastError ; if FALSE, error, get it store lastError,eax ; keep copy in lastError, this is a GetLastError err push eax ; push error ior next znamemanque <SAVE-CON> ; -- x1 .. xn fw_SAVECON: ; save console and other specs ctok NEST literal lastCatch ; holds catch frame pointer ctok FETCH literal lastCaught ; holds IP pointing to cell following THROW ctok FETCH literal conMode ; Holds Console Mode ctok FETCH literal ntConEBP ; holds value of EBP from startup ctok FETCH literal ntConESP ; holds value of ESP from startup ctok FETCH literal memHandle ; pointer to allocated memory block ctok FETCH literal stdIn ; Console handle ctok FETCH literal stdOut ; Console handle ctok FETCH literal stdErr ; Console handle ctok FETCH ctok SP0 ; initial SP ctok FETCH literal rpzero ; initial RP ctok FETCH ctok UNNEST znamemanque <RESTORE-CON> ; x1 .. xn -- fw_RESTCON: ; Restore console and other specs ctok NEST literal rpzero ; initial RP ctok STORE ctok SP0 ; initial SP ctok STORE literal stdErr ; Console handle ctok STORE literal stdOut ; Console handle ctok STORE literal stdIn ; Console handle ctok STORE literal memHandle ; pointer to allocated memory block ctok STORE literal ntConESP ; holds value of ESP from startup ctok STORE literal ntConEBP ; holds value of EBP from startup ctok STORE literal conMode ; Holds Console Mode ctok STORE literal lastCaught ; holds IP pointing to cell following THROW ctok STORE literal lastCatch ; holds catch frame pointer ctok STORE ctok UNNEST snamemanque <RELOAD-FILE> ; file-id -- u ior fw_RELOADFILE: ctok NEST ; reloads an image from file-id ctok TO_R ; -- R: -- fid ctok SAVECON ; -- x1 .. xn R: -- fid ctok R_FROM ; -- x1 .. xn fid R: -- literal 0 ctok CODETODATA ; -- x1 .. xn fid a-addr, base of user image literal (defDataSize+defDictSize) ; -- x1 .. xn fid a-addr u, size of user image in bytes ctok ROT ; -- x1 .. xn c-addr u fid ctok READFILEA ; -- x1 .. xn u ior ctok TWO_TO_R ; -- x1 .. xn R: -- u ior ctok RESTCON ; -- R: -- u ior ctok TWO_R_FROM ; -- u ior R: -- ctok UNNEST sname <RELOADED> ; c-addr u -- u ior1 ior2 ctok NEST ; reload image from name file ctok RO ; -- c-addr u fam ctok OPENFILE ; -- fid ior compif reloaded1 literal -37 ctok THROW reloaded1: ; -- fid ctok DUP ; -- fid fid ctok RELOADFILE ; -- fid u ior ctok ROT ; -- u ior fid ctok CLOSEFILE ; -- u ior1 ior2 ctok UNNEST sname <RELOAD> ; "ccc< >" -- ctok NEST ; use on NT command line only, otherwise crap in TIB ctok BL ctok WORD ctok TO_R ; -- R: -- c-addr ctok SAVEINP ; -- n*x n ctok R_FROM ; -- n*x n c-addr ctok COUNT ; -- n*x n c-addr' u ctok RELOADED ; -- n*x n u ior1 ior2 ctok TWO_DROP ; -- n*x n ior ctok DROP ; -- n*x n ctok RESTINP ; -- ctok UNNEST sname <GETCOMMANDLINE> ; -- c-addr u docode INVOKE GetCommandLineW push eax ; push address of command line sub DWORD PTR [esp],dp ; convert to data-relative address mov ecx,eax .WHILE ( WORD PTR [eax] != 0 ) ; find null at end of string add eax,tchar .ENDW xor edx,edx sub eax,ecx mov ecx,2 div ecx push eax next ;--( Bootup ) boot: ; initialize system INVOKE LocalAlloc, LMEM_FIXED, defDataSize+defDictSize ; get mem for user dictionary & data space mov cp,eax ; return if non-null is user dictionary, must test here lea dp,[eax+defDictSize] ; data space store memHandle,eax ; save copy of mem handle for later free store ntConEBP,ebp ; preserve EBP store ntConESP,esp ; preserve ESP lea rp,[esp-dStackSize] ; set return stack pointer store rpzero,rp ; save initial return stack INVOKE GetStdHandle, STD_INPUT_HANDLE ; return is handle or INVALID_HANDLE store stdIn,eax ; store handle INVOKE GetStdHandle, STD_OUTPUT_HANDLE ; return is handle or INVALID_HANDLE store stdOut,eax ; store handle INVOKE GetStdHandle, STD_ERROR_HANDLE ; return is handle or INVALID_HANDLE store stdErr,eax ; store handle ; !!!***!!! for now, just fall thru here into bare_boot bare_boot: ; if we aren't loading a saved image store datap,varptr ; set HERE store dictp,0 ; offset end of dictionary store wllink,<OFFSET FLAT:fw_SWORDLIST> ; word list link mov DWORD PTR [dp+flinkp],flinkptr ; last link in FORTH-WORDLIST mov DWORD PTR [dp+zlinkp],zlinkptr ; last link in INTERNALS-WORDLIST mov DWORD PTR [dp+nlinkp],nlinkptr ; last link in NONSTANDARD-WORDLIST mov DWORD PTR [dp+slinkp],slinkptr ; last link in SYSTEM-WORDLIST mov ecx,searchOrderSize ; set up to clear search order xor eax,eax ; 0 lea edx,searchOrder[dp] ; address of base of search order array bb1: mov [edx],eax ; erase a cell add edx,cell ; increment address loop bb1 ; loop till done dev_boot: mov WORD PTR lastReadConW,UniNotAChar mov ip,OFFSET FLAT:cold next _main ENDP _TEXT ENDS END